From:	"NPM   [#77753554]"@FORUM.DOMAIN
Sent:	Tuesday, March 08, 2016 8:25 AM
To:	WESTRA.HERLAN_G@FORUM.DOMAIN; DAVISSON.DAVID@CHEYL93.FO-
BAYPINESURL        ; GABER.ROY@FORUM.DOMAIN; 
MORRISON.JENNIFER@FORUM.DOMAIN; 
MORRISON.JENNIFER_A@CHEYL19.DNS        URL        ; 
MORRISON.JENNIFER_A@NHML07.DNS        URL        ; 
OWEN.STEVEN_W@FORUM.DOMAIN; 
SAVKOVIC.DAVID@FORUM.DOMAIN; SHETLER.BOB@FORUM.DOMAIN; 
kilgore.connie@CHEYL118.DNS        URL        ; Shetler, Bob  
(ByLight)
Subject:	XU*8*659 TEST v9

$TXT Created by WESTRA,HERLAN at KRN.FO-OAKLANDURL          (KIDS) on Tuesday, 03/08/16 at 
06:21
=============================================================================
Run Date: MAR 08, 2016                     Designation: XU*8*659
Package : XU - KERNEL                         Priority: Mandatory
Version : 8                                     Status: Under Development
=============================================================================

Associated patches: (v)XU*8*430    <<= must be installed BEFORE `XU*8*659'
                    (v)XU*8*504    <<= must be installed BEFORE `XU*8*659'
                    (v)XU*8*584    <<= must be installed BEFORE `XU*8*659'
                    (v)XU*8*638    <<= must be installed BEFORE `XU*8*659'
                    (v)XU*8*655    <<= must be installed BEFORE `XU*8*659'

Subject: SINGLE SIGN-ON PROVISIONING AND IMPLEMENTATION

Category: 
  - Enhancement (Mandatory)
  - Routine
  - Print Template
  - Other
  - Data Dictionary

Description:
============

 This patch provides enhancements needed to implement Single Sign-On 
 Internal (SSOi) for identification and authentication of users into VistA.
  
 VAIQ #7613595 "Mandatory Use of PIV Multifactor Authentication to VA 
 Information Systems" dated June 30, 2015, requires all VA IT systems to be
 PIV-enabled and requires the use of multifactor authentication when using 
 a local, network, or remote account to log into a VA information system. 
 This patch provides the VistA Kernel utilities needed to implement this 
 requirement.
  
 The use of these utilities are expected to improve security and auditing
 capabilities in accordance with VA Handbook 6500 Appendix F and revision 4
 of NIST SP 800-53. As required by FIPS 199 and using guidance from NIST SP
 800-60, the recommended security categorization for these applications is
 HIGH.
  
 Integration with Identity and Access Management (IAM) services are 
 mandated by executive management via the following memorandums:
  - IAM Identity Services (IdS) mandate memorandum (VAIQ #7011145). All
    applications within VA must comply with IAM requirements to ensure that
    references to the identities of Veterans and their beneficiaries are 
    accurate. 
  - IAM Access Services (AcS) functionality within VA is mandated by VAIQ
    #7060071 (http://vaww.iam.DNS   /IAM_Business_PMO.asp).
  
 The following changes have been made to implement SSOi in VistA:
  
 Identity and Access Management (IAM)
  - This patch adds or updates Remote Procedures to provide Kernel support
    for the IAM Provisioning and IAM Binding applications.
  - This patch adds or updates Remote Procedures to fully implement Kernel
    processing of IAM Secure Token Service (STS) tokens for secure
    authentication and identification of users authenticated by IAM using
    Active Directory credentials (KERBEROS or PIV Card).
  - The XUS IAM BIND USER and XUS ESSO VALIDATE Remote Procedures have 
    been added to the XUS SIGNON menu option to make them available to all 
    users.
  
 VistA Kernel Security
  - Per the VA Authentication, Authorization, and Audit (AAA) Design 
    Pattern, VA Applications shall implement Level of Assurance (LOA) 
    requirements for authentication. VA shall use guidance from OMB 04-04
    and NIST SP 800-63-2 to rate all existing applications to their
    appropriate LOA and implement appropriate security controls for user
    authentication to those applications. LOA for a user's authentication
    shall be determined by the weakest link in the authentication process.
    Application authentication protocols shall comply with all existing
    policy established in VA 6500.
  - This patch identifies the sign-on LOA when authenticating a user into 
    VistA using traditional and newly-developed authentication methods.
  - This patch records the LOA in the SIGN-ON LOG file (#3.081) if the 
    information is available.
  - In the future, when LOA identification is fully implemented into Kernel
    Security, access to VistA will be denied when little or no confidence 
    exists in the asserted user identity (DUZ("LOA")=1). Until then, VistA 
    application developers can choose to limit or deny access to individual
    applications or data when DUZ("LOA")=1.
  
 Veterans Access, Choice, and Accountability Act of 2014 (VACAA)
 - This patch updates the API introduced in XU*8.0*655 to bulk-load non-VA 
   entities and providers. The updated API provides a means of making 
   recurring updates to the NEW PERSON file (#200) to identify non-VA
   providers when documenting patient care. The API is provided to
   Outpatient Pharmacy under private Integration Agreement #6230.
  
  
 Blood Bank Clearance
 ====================
 Clearance - 01/13/2015
 EFFECT ON BLOOD BANK FUNCTIONAL REQUIREMENTS: Patch XU*8.0*659 contains 
 changes to a package referenced in ProPath standard titled BBM Team 
 Review of VistA Patches. This patch does not alter or modify any VistA
 Blood Bank software design safeguards or safety critical elements
 functions.
   
 RISK ANALYSIS: Changes made by patch XU*8.0*659 have no effect on Blood 
 Bank software functionality, therefore RISK is none.
  
  
 Patch Components
 ================
  
 Files & Fields Associated:
  
 File Name (Number)   Field Name (Number)             New/Modified/Deleted
 ------------------   -------------------             --------------------
 KERNEL SYSTEM PARAMETERS (#8989.3)
                      SECURITY TOKEN SERVICE (#200.1) New
                      ORGANIZATION (#200.2)           New
                      ORGANIZATION ID (#200.3)        New
 SIGN-ON LOG (#3.081) LEVEL OF ASSURANCE (#101)       New 
  
  
 Forms Associated:
  
 Form Name                Type                      New/Modified/Deleted
 ---------                ----                      -------------------- 
 N/A
  
  
 Options Associated:
  
 Option Name            Type                      New/Modified/Deleted
 -----------            ----                      -------------------- 
 XUS SIGNON             Broker (Client/Server)    MODIFIED
 XUS VISIT USERS        Print                     MODIFIED
 XUSEC REMOTE ACCESS    Print                     MODIFIED
  
  
 Protocols Associated:
 --------------------
 N/A
  
  
 Security Keys Associated:
 ------------------------
 N/A
  
  
 Templates Associated:
  
 Template Name       Type    File Name (Number)   New/Modified/Deleted 
 -------------       ----    ------------------   --------------------
 XUSEC LIST          Print   SIGN-ON LOG (3.081)  Modified
 XUSEC REMOTE ACCESS Print   SIGN-ON LOG (3.081)  Modified 
  
  
 Remote Procedure Calls Associated:
  
 RPC Name                      Type         New/Modified/Deleted
 --------                      ----         --------------------
 XUS ALLKEYS                   PUBLIC       Modified (description only)
 XUS AV CODE                   RESTRICTED   Modified (description only)
 XUS BSE TOKEN                 SUBSCRIPTION New
 XUS CVC                       RESTRICTED   Modified (description only)
 XUS ESSO VALIDATE             RESTRICTED   Modified
 XUS IAM ADD USER              SUBSCRIPTION Modified
 XUS IAM BIND USER             SUBSCRIPTION Modified
 XUS IAM DISPLAY USER          SUBSCRIPTION Modified
 XUS IAM EDIT USER             SUBSCRIPTION Modified
 XUS IAM FIND USER             SUBSCRIPTION Modified
 XUS IAM REACTIVATE USER       SUBSCRIPTION New
 XUS IAM TERMINATE USER        SUBSCRIPTION New
 XUS KAAJEE GET CCOW TOKEN     RESTRICTED   Modified (description only)
 XUS KAAJEE GET USER INFO      AGREEMENT    Modified (description only)
 XUS KAAJEE GET USER VIA PROXY RESTRICTED   Modified (description only)
 XUS KAAJEE GET LOGOUT         AGREEMENT    Modified (description only)
 XUS KEY CHECK                 PUBLIC       Modified (description only)
 XUS SIGNON SETUP              SUBSCRIPTION Modified (description only)
  
  
 New Service Requests (NSRs)
 ----------------------------  
 N/A
  
  
 Patient Safety Issues (PSIs)
 -----------------------------
 N/A
  
  
 Remedy Ticket(s) & Overview
 ---------------------------
  I5606567FY15 VAIQ #7060071 IAM Access Services (AcS) functionality
  
 1. I5606567FY15 VAIQ #7060071 IAM Access Services (AcS) functionality
  
 Problem:
 -------
 Integration with Identity and Access Management (IAM) services are 
 mandated by executive management via VAIQ #7011145 and VAIQ #7060071.
  
 Resolution:
 ----------
 This patch provides the finished interfaces to identify and authenticate 
 a user into VistA using a Security Assertion Markup Language (SAML) token 
 from the IAM Secure Token Service (STS), and provides the interfaces for 
 an IAM Provisioning application to configure users to be identified by 
 SAML token.
  
  
 Test Sites: (Patch Tracking Message #76891612)
 ----------
 [Potential test sites - Update list and remove POCs before release]
 Boise VA Medical Center, Boise ID (531 - Medium)
   [Wil Marchand and Belinda Dalton]
 Cheyenne VA Medical, Cheyenne WY (442 - Medium)
   [Wil Marchand and Belinda Dalton] 
 Clement J. Zablocki Veterans Affairs Medical Center, Milwaukee WI (695 - 
 Large) 
   [Bryan Vail]
 Hampton VA Medical Center, Hampton VA (590 - Large)
   [Djabatey O Kwashie]
 Hunter Holmes McGuire VA Medical Center, Richmond VA (652 - Large)
   [Charles G Autry]
 Memphis VA Medical Center, Memphis TN (618 - Large)
   [Neil A. Lewis]
 Minneapolis VA Medical Center, Minneapolis MN (618 - Large)
   [Stan R. Bush]
 Philadelphia VA Medical Center, Philadelphia PA (642 - Large)
 VA Central Western Massachusetts HCS (Northampton), Leeds MA (631 - 
 Medium)
 VA Hudson Valley HCS, Montrose NY (620 - Integrated)
 VA Puget Sound Health Care System, Seattle WA (663 - Integrated)
   [Wil Marchand and Belinda Dalton]
 VA South Texas Veterans Health Care System, San Antonio TX (671 - 
 Integrated)
   [Simon D Willett]
 Washington DC VA Medical Center, Washington DC (688 - Large)
  
  
 Documentation Retrieval Instructions
 ------------------------------------ 
 No changes have been made to Kernel documentation as a result of this 
 patch. However, the most up-to-date VA Kernel end-user documentation 
 is available on the VHA Software Document Library (VDL) at the following
 Internet Website:
      http://www.DNS   /vdl/application.asp?appid=10
   
 NOTE: VistA documentation is made available online in Microsoft Word 
 format (.DOC) and Adobe Acrobat Portable Document Format (.PDF).
  
  
  
 Patch Installation:
  
  
 Pre-Installation Instructions
 -----------------------------
 This patch can be NOT be queued for installation, since the post-
 installation routine requires interactive input. TaskMan does not have to
 be stopped, HL7 filers do not need to be stopped, and users may be on the
 system.  There are no menu options or protocols that need to be disabled.
  
 Installation Instructions
 -------------------------
 This patch may be installed with users on the system.  This patch should 
 take less than 1 minute to install.  It may be queued for installation.
  
 There are no options that need to be disabled.
  
 1.  Choose the PackMan message containing this patch.
  
 2.  Choose the INSTALL/CHECK MESSAGE PackMan option.  
  
 3.  From the Kernel Installation and Distribution System Menu, select
     the Installation Menu.  From this menu, you may elect to use the
     following option. When prompted for the INSTALL enter the patch #(ex.
     XU*8.0*659):
  
     a.  Print Transport Global - This option lets you print the contents
         of a Transport Global that is currently loaded in the ^XTMP
         global.
     b.  Backup a Transport Global - This option will create a backup
         message of any routines exported with this patch. It will not
         backup any other changes such as DDs or templates.
     c.  Compare Transport Global to Current System - This option will
         allow you to view all changes that will be made when this patch
         is installed.  It compares all components of this patch
         (routines, DDs, templates, etc.).
     d.  Verify Checksums in Transport Global - This option will allow
         you to ensure the integrity of the routines that are in the
         transport global.
      
 4.  From the Installation Menu, select the Install Package(s) option and
     choose the patch to install.
  
 5.  If prompted 'Want KIDS to Rebuild Menu Trees Upon Completion of
     Install? NO//' answer "NO".   
  
 6.  When prompted 'Want KIDS to INHIBIT LOGONs during the install?
     NO//' answer "NO".
  
 7.  If prompted 'Want to DISABLE Scheduled Options, Menu Options, 
     and Protocols? NO//' answer "NO".
  
 8.  If prompted 'Delay Install (Minutes):  (0 - 60): 0//' answer "0" to 
     "60" or "Q" (to queue the output to a printer).
  
  
 Post-Installation Instructions
 ------------------------------
 There are no post-installation tasks. A post-installation routine will 
 run upon patch installation to install data in specific locations. The 
 expected output will be similar to the following. If your output shows 
 error messages, an incident ticket should be opened to troubleshoot your 
 patch installation.
  
   OPTION exists at IEN = 11418
  
      REMOTE APPLICATION entry created: IAM PROVISIONING
  
   OPTION exists at IEN = 11419
  
      REMOTE APPLICATION entry created: IAM BINDING
  
   OPTION WEBN NATL UTIL MGMT INTEG created
  
      REMOTE APPLICATION entry created: NUMI
  
   OPTION WEBB BED MGMT SOLUTION created
  
      REMOTE APPLICATION entry created: BMS
  
      DIALOG entry created: STS token not valid.
  
      KERNEL SYSTEM PARAMETERS fields populated: SECURITY TOKEN SERVICE,  
   ORGANIZATION, ORGANIZATION ID

Routine Information:
====================
The second line of each of these routines now looks like:
 ;;8.0;KERNEL;**[Patch List]**;Jul 10, 1995;Build 22

The checksums below are new checksums, and
 can be checked with CHECK1^XTSUMBLD.

Routine Name: XLFNSLK
    Before: B44384655   After: B39616756  **142,151,425,638,659**
Routine Name: XU8PS655
    Before:B102640640   After:    Delete  
Routine Name: XU8PS659
    Before:       n/a   After: B63050406  **659**
Routine Name: XUCERT
    Before:       n/a   After:  B4132125  **659**
Routine Name: XUCERT1
    Before:       n/a   After: B20606802  **659**
Routine Name: XUESSO1
    Before: B77693554   After: B93859687  **165,183,196,245,254,269,337,
                                           395,466,523,655,659**
Routine Name: XUESSO2
    Before:B108993229   After:B117714262  **655,659**
Routine Name: XUESSO3
    Before:B206943521   After:B221983051  **655,659**
Routine Name: XUESSO4
    Before:       n/a   After: B61505269  **659**
Routine Name: XUP
    Before: B11551061   After: B11898665  **208,258,284,432,469,659**
Routine Name: XUS
    Before: B31567708   After: B35560117  **16,26,49,59,149,180,265,337,
                                           419,434,584,659**
Routine Name: XUS1
    Before: B28568204   After: B29132312  **9,59,111,165,150,252,265,419,
                                           469,523,543,638,659**
Routine Name: XUSAML
    Before: B78896546   After: B87822485  **655,659**
Routine Name: XUSBSE1
    Before:B117144392   After:B158984065  **404,439,523,595,522,638,659**
Routine Name: XUSHSH
    Before: B31040658   After: B37891600  **655,659**
Routine Name: XUSKAAJ
    Before: B11629985   After: B11718164  **329,430,659**
Routine Name: XUSKAAJ1
    Before:  B1687417   After:  B2125056  **504,659**
Routine Name: XUSRB
    Before: B33401626   After: B35393386  **11,16,28,32,59,70,82,109,115,
                                           165,150,180,213,234,238,265,
                                           337,395,404,437,523,659**
Routine Name: XUSRB4
    Before: B18435992   After: B20805610  **150,337,395,419,437,499,523,
                                           573,596,638,659**
 
Routine list of preceding patches: 430, 504, 584, 638, 655

=============================================================================
User Information:
Entered By  : WESTRA,HERLAN G               Date Entered  : MAY 21, 2015
Completed By:                               Date Completed: 
Released By :                               Date Released : 
=============================================================================


Packman Mail Message:
=====================

$END TXT
$KID XU*8.0*659
**INSTALL NAME**
XU*8.0*659
"BLD",1548,0)
XU*8.0*659^KERNEL^0^3160308^y
"BLD",1548,1,0)
^^8^8^3160308^
"BLD",1548,1,1,0)
This patch provides enhancements needed to implement Single Sign-On 
"BLD",1548,1,2,0)
Internal (SSOi) for identification and authentication of users into VistA.
"BLD",1548,1,3,0)
 
"BLD",1548,1,4,0)
The use of these utilities are expected to improve security and auditing
"BLD",1548,1,5,0)
capabilities in accordance with VA Handbook 6500 Appendix F and revision 4
"BLD",1548,1,6,0)
of NIST SP 800-53. As required by FIPS 199 and using guidance from NIST SP
"BLD",1548,1,7,0)
800-60, the recommended security categorization for these applications is
"BLD",1548,1,8,0)
HIGH.
"BLD",1548,4,0)
^9.64PA^8989.3^2
"BLD",1548,4,3.081,0)
3.081
"BLD",1548,4,3.081,2,0)
^9.641^3.081^1
"BLD",1548,4,3.081,2,3.081,0)
SIGN-ON LOG  (File-top level)
"BLD",1548,4,3.081,2,3.081,1,0)
^9.6411^101^1
"BLD",1548,4,3.081,2,3.081,1,101,0)
LEVEL OF ASSURANCE
"BLD",1548,4,3.081,222)
y^y^p^^^^n^^n
"BLD",1548,4,3.081,224)

"BLD",1548,4,8989.3,0)
8989.3
"BLD",1548,4,8989.3,2,0)
^9.641^8989.3^1
"BLD",1548,4,8989.3,2,8989.3,0)
KERNEL SYSTEM PARAMETERS  (File-top level)
"BLD",1548,4,8989.3,2,8989.3,1,0)
^9.6411^200.3^3
"BLD",1548,4,8989.3,2,8989.3,1,200.1,0)
SECURITY TOKEN SERVICE
"BLD",1548,4,8989.3,2,8989.3,1,200.2,0)
ORGANIZATION
"BLD",1548,4,8989.3,2,8989.3,1,200.3,0)
ORGANIZATION ID
"BLD",1548,4,8989.3,222)
y^y^p^^^^n^^n
"BLD",1548,4,8989.3,224)

"BLD",1548,4,"APDD",3.081,3.081)

"BLD",1548,4,"APDD",3.081,3.081,101)

"BLD",1548,4,"APDD",8989.3,8989.3)

"BLD",1548,4,"APDD",8989.3,8989.3,200.1)

"BLD",1548,4,"APDD",8989.3,8989.3,200.2)

"BLD",1548,4,"APDD",8989.3,8989.3,200.3)

"BLD",1548,4,"B",3.081,3.081)

"BLD",1548,4,"B",8989.3,8989.3)

"BLD",1548,6.3)
22
"BLD",1548,"ABPKG")
n
"BLD",1548,"INID")
^y
"BLD",1548,"INIT")
XU8PS659
"BLD",1548,"KRN",0)
^9.67PA^779.2^20
"BLD",1548,"KRN",.4,0)
.4
"BLD",1548,"KRN",.4,"NM",0)
^9.68A^2^2
"BLD",1548,"KRN",.4,"NM",1,0)
XUSEC LIST    FILE #3.081^3.081^0
"BLD",1548,"KRN",.4,"NM",2,0)
XUSEC REMOTE ACCESS    FILE #3.081^3.081^0
"BLD",1548,"KRN",.4,"NM","B","XUSEC LIST    FILE #3.081",1)

"BLD",1548,"KRN",.4,"NM","B","XUSEC REMOTE ACCESS    FILE #3.081",2)

"BLD",1548,"KRN",.401,0)
.401
"BLD",1548,"KRN",.402,0)
.402
"BLD",1548,"KRN",.403,0)
.403
"BLD",1548,"KRN",.5,0)
.5
"BLD",1548,"KRN",.84,0)
.84
"BLD",1548,"KRN",3.6,0)
3.6
"BLD",1548,"KRN",3.8,0)
3.8
"BLD",1548,"KRN",9.2,0)
9.2
"BLD",1548,"KRN",9.8,0)
9.8
"BLD",1548,"KRN",9.8,"NM",0)
^9.68A^30^18
"BLD",1548,"KRN",9.8,"NM",7,0)
XUS^^0^B35560117
"BLD",1548,"KRN",9.8,"NM",8,0)
XUSRB^^0^B35393386
"BLD",1548,"KRN",9.8,"NM",9,0)
XUSBSE1^^0^B158984065
"BLD",1548,"KRN",9.8,"NM",10,0)
XUS1^^0^B29132312
"BLD",1548,"KRN",9.8,"NM",11,0)
XUESSO1^^0^B93859687
"BLD",1548,"KRN",9.8,"NM",12,0)
XUESSO2^^0^B117714262
"BLD",1548,"KRN",9.8,"NM",13,0)
XUESSO3^^0^B221983051
"BLD",1548,"KRN",9.8,"NM",14,0)
XUSAML^^0^B87822485
"BLD",1548,"KRN",9.8,"NM",17,0)
XU8PS655^^1^
"BLD",1548,"KRN",9.8,"NM",18,0)
XUCERT^^0^B4132125
"BLD",1548,"KRN",9.8,"NM",19,0)
XUESSO4^^0^B61505269
"BLD",1548,"KRN",9.8,"NM",20,0)
XUP^^0^B11898665
"BLD",1548,"KRN",9.8,"NM",21,0)
XUSRB4^^0^B20805610
"BLD",1548,"KRN",9.8,"NM",22,0)
XUCERT1^^0^B20606802
"BLD",1548,"KRN",9.8,"NM",27,0)
XLFNSLK^^0^B39616756
"BLD",1548,"KRN",9.8,"NM",28,0)
XUSKAAJ^^0^B11718164
"BLD",1548,"KRN",9.8,"NM",29,0)
XUSKAAJ1^^0^B2125056
"BLD",1548,"KRN",9.8,"NM",30,0)
XUSHSH^^0^B37891600
"BLD",1548,"KRN",9.8,"NM","B","XLFNSLK",27)

"BLD",1548,"KRN",9.8,"NM","B","XU8PS655",17)

"BLD",1548,"KRN",9.8,"NM","B","XUCERT",18)

"BLD",1548,"KRN",9.8,"NM","B","XUCERT1",22)

"BLD",1548,"KRN",9.8,"NM","B","XUESSO1",11)

"BLD",1548,"KRN",9.8,"NM","B","XUESSO2",12)

"BLD",1548,"KRN",9.8,"NM","B","XUESSO3",13)

"BLD",1548,"KRN",9.8,"NM","B","XUESSO4",19)

"BLD",1548,"KRN",9.8,"NM","B","XUP",20)

"BLD",1548,"KRN",9.8,"NM","B","XUS",7)

"BLD",1548,"KRN",9.8,"NM","B","XUS1",10)

"BLD",1548,"KRN",9.8,"NM","B","XUSAML",14)

"BLD",1548,"KRN",9.8,"NM","B","XUSBSE1",9)

"BLD",1548,"KRN",9.8,"NM","B","XUSHSH",30)

"BLD",1548,"KRN",9.8,"NM","B","XUSKAAJ",28)

"BLD",1548,"KRN",9.8,"NM","B","XUSKAAJ1",29)

"BLD",1548,"KRN",9.8,"NM","B","XUSRB",8)

"BLD",1548,"KRN",9.8,"NM","B","XUSRB4",21)

"BLD",1548,"KRN",19,0)
19
"BLD",1548,"KRN",19,"NM",0)
^9.68A^3^3
"BLD",1548,"KRN",19,"NM",1,0)
XUS SIGNON^^0
"BLD",1548,"KRN",19,"NM",2,0)
XUS VISIT USERS^^0
"BLD",1548,"KRN",19,"NM",3,0)
XUSEC REMOTE ACCESS^^0
"BLD",1548,"KRN",19,"NM","B","XUS SIGNON",1)

"BLD",1548,"KRN",19,"NM","B","XUS VISIT USERS",2)

"BLD",1548,"KRN",19,"NM","B","XUSEC REMOTE ACCESS",3)

"BLD",1548,"KRN",19.1,0)
19.1
"BLD",1548,"KRN",101,0)
101
"BLD",1548,"KRN",101,"NM",0)
^9.68A^^0
"BLD",1548,"KRN",409.61,0)
409.61
"BLD",1548,"KRN",771,0)
771
"BLD",1548,"KRN",779.2,0)
779.2
"BLD",1548,"KRN",870,0)
870
"BLD",1548,"KRN",8989.51,0)
8989.51
"BLD",1548,"KRN",8989.52,0)
8989.52
"BLD",1548,"KRN",8994,0)
8994
"BLD",1548,"KRN",8994,"NM",0)
^9.68A^18^18
"BLD",1548,"KRN",8994,"NM",1,0)
XUS ESSO VALIDATE^^0
"BLD",1548,"KRN",8994,"NM",2,0)
XUS IAM FIND USER^^0
"BLD",1548,"KRN",8994,"NM",3,0)
XUS IAM DISPLAY USER^^0
"BLD",1548,"KRN",8994,"NM",4,0)
XUS IAM EDIT USER^^0
"BLD",1548,"KRN",8994,"NM",5,0)
XUS IAM ADD USER^^0
"BLD",1548,"KRN",8994,"NM",6,0)
XUS IAM BIND USER^^0
"BLD",1548,"KRN",8994,"NM",7,0)
XUS IAM TERMINATE USER^^0
"BLD",1548,"KRN",8994,"NM",8,0)
XUS IAM REACTIVATE USER^^0
"BLD",1548,"KRN",8994,"NM",9,0)
XUS CVC^^0
"BLD",1548,"KRN",8994,"NM",10,0)
XUS SIGNON SETUP^^0
"BLD",1548,"KRN",8994,"NM",11,0)
XUS ALLKEYS^^0
"BLD",1548,"KRN",8994,"NM",12,0)
XUS KEY CHECK^^0
"BLD",1548,"KRN",8994,"NM",13,0)
XUS KAAJEE GET CCOW TOKEN^^0
"BLD",1548,"KRN",8994,"NM",14,0)
XUS KAAJEE GET USER INFO^^0
"BLD",1548,"KRN",8994,"NM",15,0)
XUS KAAJEE GET USER VIA PROXY^^0
"BLD",1548,"KRN",8994,"NM",16,0)
XUS KAAJEE LOGOUT^^0
"BLD",1548,"KRN",8994,"NM",17,0)
XUS BSE TOKEN^^0
"BLD",1548,"KRN",8994,"NM",18,0)
XUS AV CODE^^0
"BLD",1548,"KRN",8994,"NM","B","XUS ALLKEYS",11)

"BLD",1548,"KRN",8994,"NM","B","XUS AV CODE",18)

"BLD",1548,"KRN",8994,"NM","B","XUS BSE TOKEN",17)

"BLD",1548,"KRN",8994,"NM","B","XUS CVC",9)

"BLD",1548,"KRN",8994,"NM","B","XUS ESSO VALIDATE",1)

"BLD",1548,"KRN",8994,"NM","B","XUS IAM ADD USER",5)

"BLD",1548,"KRN",8994,"NM","B","XUS IAM BIND USER",6)

"BLD",1548,"KRN",8994,"NM","B","XUS IAM DISPLAY USER",3)

"BLD",1548,"KRN",8994,"NM","B","XUS IAM EDIT USER",4)

"BLD",1548,"KRN",8994,"NM","B","XUS IAM FIND USER",2)

"BLD",1548,"KRN",8994,"NM","B","XUS IAM REACTIVATE USER",8)

"BLD",1548,"KRN",8994,"NM","B","XUS IAM TERMINATE USER",7)

"BLD",1548,"KRN",8994,"NM","B","XUS KAAJEE GET CCOW TOKEN",13)

"BLD",1548,"KRN",8994,"NM","B","XUS KAAJEE GET USER INFO",14)

"BLD",1548,"KRN",8994,"NM","B","XUS KAAJEE GET USER VIA PROXY",15)

"BLD",1548,"KRN",8994,"NM","B","XUS KAAJEE LOGOUT",16)

"BLD",1548,"KRN",8994,"NM","B","XUS KEY CHECK",12)

"BLD",1548,"KRN",8994,"NM","B","XUS SIGNON SETUP",10)

"BLD",1548,"KRN","B",.4,.4)

"BLD",1548,"KRN","B",.401,.401)

"BLD",1548,"KRN","B",.402,.402)

"BLD",1548,"KRN","B",.403,.403)

"BLD",1548,"KRN","B",.5,.5)

"BLD",1548,"KRN","B",.84,.84)

"BLD",1548,"KRN","B",3.6,3.6)

"BLD",1548,"KRN","B",3.8,3.8)

"BLD",1548,"KRN","B",9.2,9.2)

"BLD",1548,"KRN","B",9.8,9.8)

"BLD",1548,"KRN","B",19,19)

"BLD",1548,"KRN","B",19.1,19.1)

"BLD",1548,"KRN","B",101,101)

"BLD",1548,"KRN","B",409.61,409.61)

"BLD",1548,"KRN","B",771,771)

"BLD",1548,"KRN","B",779.2,779.2)

"BLD",1548,"KRN","B",870,870)

"BLD",1548,"KRN","B",8989.51,8989.51)

"BLD",1548,"KRN","B",8989.52,8989.52)

"BLD",1548,"KRN","B",8994,8994)

"BLD",1548,"PRET")

"BLD",1548,"QUES",0)
^9.62^^
"BLD",1548,"REQB",0)
^9.611^5^5
"BLD",1548,"REQB",1,0)
XU*8.0*655^1
"BLD",1548,"REQB",2,0)
XU*8.0*638^1
"BLD",1548,"REQB",3,0)
XU*8.0*584^1
"BLD",1548,"REQB",4,0)
XU*8.0*430^1
"BLD",1548,"REQB",5,0)
XU*8.0*504^1
"BLD",1548,"REQB","B","XU*8.0*430",4)

"BLD",1548,"REQB","B","XU*8.0*504",5)

"BLD",1548,"REQB","B","XU*8.0*584",3)

"BLD",1548,"REQB","B","XU*8.0*638",2)

"BLD",1548,"REQB","B","XU*8.0*655",1)

"FIA",3.081)
SIGN-ON LOG
"FIA",3.081,0)
^XUSEC(0,
"FIA",3.081,0,0)
3.081P
"FIA",3.081,0,1)
y^y^p^^^^n^^n
"FIA",3.081,0,10)

"FIA",3.081,0,11)

"FIA",3.081,0,"RLRO")

"FIA",3.081,0,"VR")
8.0^XU
"FIA",3.081,3.081)
1
"FIA",3.081,3.081,101)

"FIA",8989.3)
KERNEL SYSTEM PARAMETERS
"FIA",8989.3,0)
^XTV(8989.3,
"FIA",8989.3,0,0)
8989.3P
"FIA",8989.3,0,1)
y^y^p^^^^n^^n
"FIA",8989.3,0,10)

"FIA",8989.3,0,11)

"FIA",8989.3,0,"RLRO")

"FIA",8989.3,0,"VR")
8.0^XU
"FIA",8989.3,8989.3)
1
"FIA",8989.3,8989.3,200.1)

"FIA",8989.3,8989.3,200.2)

"FIA",8989.3,8989.3,200.3)

"INIT")
XU8PS659
"KRN",.4,3,-1)
0^1
"KRN",.4,3,0)
XUSEC LIST^3150902.0721^^3.081^^@^3160224
"KRN",.4,3,"F",2)
0;"Sign-on time"~99;R9~.01;L17~S X=$I W X K DIP;L9;Z;"$I"~10~100;L40~101;"LOA"~
"KRN",.4,3,"H")
USERS WHO HAVE SIGNED ONTO THE COMPUTER
"KRN",.4,70,-1)
0^2
"KRN",.4,70,0)
XUSEC REMOTE ACCESS^3150902.0725^@^3.081^^@^3151222
"KRN",.4,70,"F",2)
0;"Sign-on time"~99;R9~.01~14~100;L40~101;"LOA"~
"KRN",.4,70,"H")
Remote Access User Sign-On Log
"KRN",19,604,-1)
0^1
"KRN",19,604,0)
XUS SIGNON^Kernel sign-on context^^B^^^^^^^^KERNEL^y
"KRN",19,604,99.1)
61634,51614
"KRN",19,604,"RPC",0)
^19.05P^14^14
"KRN",19,604,"RPC",1,0)
XUS SIGNON SETUP
"KRN",19,604,"RPC",2,0)
XUS AV CODE
"KRN",19,604,"RPC",3,0)
XUS INTRO MSG
"KRN",19,604,"RPC",4,0)
XUS CVC
"KRN",19,604,"RPC",5,0)
XUS AV HELP
"KRN",19,604,"RPC",6,0)
XUS DIVISION SET
"KRN",19,604,"RPC",7,0)
XUS GET USER INFO
"KRN",19,604,"RPC",8,0)
XUS DIVISION GET
"KRN",19,604,"RPC",9,0)
XWB GET BROKER INFO
"KRN",19,604,"RPC",10,0)
XUS GET TOKEN
"KRN",19,604,"RPC",11,0)
XUS CCOW VAULT PARAM
"KRN",19,604,"RPC",12,0)
XUS GET CCOW TOKEN
"KRN",19,604,"RPC",13,0)
XUS ESSO VALIDATE
"KRN",19,604,"RPC",14,0)
XUS IAM BIND USER
"KRN",19,604,"U")
KERNEL SIGN-ON CONTEXT
"KRN",19,1654,-1)
0^2
"KRN",19,1654,0)
XUS VISIT USERS^Users with Foreign Visits^^P^^^^^^^^KERNEL
"KRN",19,1654,1,0)
^^2^2^3151016^
"KRN",19,1654,1,1,0)
Menu option created by patch XU*8*655 using sort and print templates from 
"KRN",19,1654,1,2,0)
patch XU*8*165. Shows NPF entries that have been VISITORS to this site.
"KRN",19,1654,60)
VA(200,
"KRN",19,1654,62)
0
"KRN",19,1654,63)
[XUS VISIT USERS]
"KRN",19,1654,64)
[XUS VISIT USERS]
"KRN",19,1654,65)

"KRN",19,1654,66)

"KRN",19,1654,"U")
USERS WITH FOREIGN VISITS
"KRN",19,1655,-1)
0^3
"KRN",19,1655,0)
XUSEC REMOTE ACCESS^Remote Access User Sign-on Log^^P^^^^^^^^KERNEL
"KRN",19,1655,1,0)
^^10^10^3151014^
"KRN",19,1655,1,1,0)
Menu option created by patch XU*8*655 using sort and print templates from 
"KRN",19,1655,1,2,0)
patch XU*8*165. Prints Sign-on log entries from remote users. Added 
"KRN",19,1655,1,3,0)
sign-on Level Of Assurance information in patch XU*8*659 where: 
"KRN",19,1655,1,4,0)
  LOA=1 - little or no confidence in the user identity (self-asserted)
"KRN",19,1655,1,5,0)
  LOA=2 - confidence in the user identity (access/verify code or
"KRN",19,1655,1,6,0)
          re-authentication token)
"KRN",19,1655,1,7,0)
  LOA=3 - high confidence in the user identity (password with hardware or 
"KRN",19,1655,1,8,0)
          software token)
"KRN",19,1655,1,9,0)
  LOA=4 - very high confidence in the user identity (in-person 
"KRN",19,1655,1,10,0)
          registration with multi-factor authentication or PIV card)
"KRN",19,1655,60)
XUSEC(0,
"KRN",19,1655,62)
0
"KRN",19,1655,63)
[XUSEC REMOTE ACCESS]
"KRN",19,1655,64)
[XUSEC REMOTE ACCESS]
"KRN",19,1655,65)

"KRN",19,1655,66)

"KRN",19,1655,"U")
REMOTE ACCESS USER SIGN-ON LOG
"KRN",8994,15,-1)
0^10
"KRN",8994,15,0)
XUS SIGNON SETUP^SETUP^XUSRB^2^S^^^^1^^1
"KRN",8994,15,1,0)
^^2^2^3151209^
"KRN",8994,15,1,1,0)
RPC ICR #1632 - API ICR #4054
"KRN",8994,15,1,2,0)
Establishes the environment necessary for VistA sign-on.
"KRN",8994,15,2,0)
^8994.02A^3^3
"KRN",8994,15,2,1,0)
XWBUSRNM^1^90^0^1
"KRN",8994,15,2,1,1,0)
^^1^1^3151201^
"KRN",8994,15,2,1,1,1,0)
Optional Broker Security Enhancement (BSE) token.
"KRN",8994,15,2,2,0)
ASOSKIP^1^1^0^2
"KRN",8994,15,2,2,1,0)
^^3^3^3151201^
"KRN",8994,15,2,2,1,1,0)
Optional. Set ASOSKIP=1 to skip the Auto Sign-On check. Used by RPC 
"KRN",8994,15,2,2,1,2,0)
applications that do not reside on the client workstation with the 
"KRN",8994,15,2,2,1,3,0)
ClAgent.exe application.
"KRN",8994,15,2,3,0)
D20^1^1^0^3
"KRN",8994,15,2,3,1,0)
^^1^1^3151201^
"KRN",8994,15,2,3,1,1,0)
Not currently used. Leave blank.
"KRN",8994,15,2,"B","ASOSKIP",2)

"KRN",8994,15,2,"B","D20",3)

"KRN",8994,15,2,"B","XWBUSRNM",1)

"KRN",8994,15,2,"PARAMSEQ",1,1)

"KRN",8994,15,2,"PARAMSEQ",2,2)

"KRN",8994,15,2,"PARAMSEQ",3,3)

"KRN",8994,15,3,0)
^^8^8^3151201^
"KRN",8994,15,3,1,0)
 RET(0)=server name
"KRN",8994,15,3,2,0)
 RET(1)=volume
"KRN",8994,15,3,3,0)
 RET(2)=uci
"KRN",8994,15,3,4,0)
 RET(3)=device
"KRN",8994,15,3,5,0)
 RET(4)=# attempts
"KRN",8994,15,3,6,0)
 RET(5)=skip signon-screen
"KRN",8994,15,3,7,0)
 RET(6)=Domain Name
"KRN",8994,15,3,8,0)
 RET(7)=production (0=no, 1=yes)
"KRN",8994,16,-1)
0^18
"KRN",8994,16,0)
XUS AV CODE^VALIDAV^XUSRB^2^R^^^^1^^0
"KRN",8994,16,1,0)
^8994.01^10^10^3151217^^^^
"KRN",8994,16,1,1,0)
This API checks if a ACCESS/VERIFY code pair is valid.
"KRN",8994,16,1,2,0)
It returns an array of values
"KRN",8994,16,1,3,0)
 
"KRN",8994,16,1,4,0)
R(0)=DUZ if sign-on was OK, zero if not OK.
"KRN",8994,16,1,5,0)
R(1)=(0=OK, 1,2...=Can't sign-on for some reason).
"KRN",8994,16,1,6,0)
R(2)=verify needs changing.
"KRN",8994,16,1,7,0)
R(3)=Message.
"KRN",8994,16,1,8,0)
R(4)=0
"KRN",8994,16,1,9,0)
R(5)=count of the number of lines of text, zero if none.
"KRN",8994,16,1,10,0)
R(5+n)=message text.
"KRN",8994,16,2,0)
^8994.02A^1^1
"KRN",8994,16,2,1,0)
AVCODE^1^60^1
"KRN",8994,16,2,1,1,0)
^8994.021^1^1^3151217^^^^
"KRN",8994,16,2,1,1,1,0)
accessCode_";"_verifyCode in unencrypted form.
"KRN",8994,16,2,"B","AVCODE",1)

"KRN",8994,18,-1)
0^12
"KRN",8994,18,0)
XUS KEY CHECK^OWNSKEY^XUSRB^2^P^^^^1^^1
"KRN",8994,18,1,0)
^^5^5^3151209^
"KRN",8994,18,1,1,0)
RPC ICR #6286 - API ICR #3277
"KRN",8994,18,1,2,0)
This RPC will check if the user (DUZ) holds a security key or an array of
"KRN",8994,18,1,3,0)
keys. If a single security KEY is sent the result is returned in R(0). If
"KRN",8994,18,1,4,0)
an array is sent down then the return array has the same order as the
"KRN",8994,18,1,5,0)
calling array.
"KRN",8994,18,2,0)
^8994.02A^2^2
"KRN",8994,18,2,1,0)
KEY^2^30^1^1
"KRN",8994,18,2,1,1,0)
^8994.021^4^4^3151208^^^^
"KRN",8994,18,2,1,1,1,0)
If key is a single value it holds the one key to check.
"KRN",8994,18,2,1,1,2,0)
If key is an array then the result is an array that matches the key
"KRN",8994,18,2,1,1,3,0)
list with values that match the status of the key check for each key.
"KRN",8994,18,2,1,1,4,0)
The return is a 1 if the user has the key and 0 if not.
"KRN",8994,18,2,2,0)
IEN^1^30^0^2
"KRN",8994,18,2,2,1,0)
^^3^3^3151209^
"KRN",8994,18,2,2,1,1,0)
(Optional) If provided, this is the IEN of the user in the NEW PERSON 
"KRN",8994,18,2,2,1,2,0)
file (#200) to check if they hold the key(s) listed in KEY. If not 
"KRN",8994,18,2,2,1,3,0)
provided, this parameter defaults to the DUZ (IEN) of the current user.
"KRN",8994,18,2,"B","IEN",2)

"KRN",8994,18,2,"B","KEY",1)

"KRN",8994,18,2,"PARAMSEQ",1,1)

"KRN",8994,18,2,"PARAMSEQ",2,2)

"KRN",8994,19,-1)
0^9
"KRN",8994,19,0)
XUS CVC^CVC^XUSRB^2^R^^^^^^0
"KRN",8994,19,1,0)
^^3^3^3151209^
"KRN",8994,19,1,1,0)
RPC ICR #6296 - API ICR #none
"KRN",8994,19,1,2,0)
This RPC is used as part of Kernel to allow the user to change their
"KRN",8994,19,1,3,0)
verify code.
"KRN",8994,19,2,0)
^8994.02A^1^1
"KRN",8994,19,2,1,0)
XU1^1^60^1^1
"KRN",8994,19,2,1,1,0)
^^4^4^3150818^
"KRN",8994,19,2,1,1,1,0)
Input:   XU1 = "current VC^new VC^new VC"
"KRN",8994,19,2,1,1,2,0)
               where current and new verify codes are individually 
"KRN",8994,19,2,1,1,3,0)
               encrypted with the VA proprietary VistA encryption
"KRN",8994,19,2,1,1,4,0)
               algorithm (client software equivalent of $$ENCRYP^XUSRB1)
"KRN",8994,19,2,"B","XU1",1)

"KRN",8994,19,2,"PARAMSEQ",1,1)

"KRN",8994,19,3,0)
^^2^2^3150818^
"KRN",8994,19,3,1,0)
R(0) = Zero if VC was changed, 1 if it could not be changed.
"KRN",8994,19,3,2,0)
R(1) = Error message if VC could not be changed.
"KRN",8994,129,-1)
0^14
"KRN",8994,129,0)
XUS KAAJEE GET USER INFO^USERINFO^XUSKAAJ^2^A^^^^1^^1
"KRN",8994,129,1,0)
^8994.01^1^1^3151215^^^^
"KRN",8994,129,1,1,0)
Returns a variety of information needed for the KAAJEE logon.
"KRN",8994,129,2,0)
^8994.02A^2^2
"KRN",8994,129,2,1,0)
CLIENT-IP^1^^1^1
"KRN",8994,129,2,1,1,0)
^^2^2^3031209^
"KRN",8994,129,2,1,1,1,0)
IP address of the client workstation, used for logging (signon log)
"KRN",8994,129,2,1,1,2,0)
and IP blocking (failed access attempts).
"KRN",8994,129,2,2,0)
SERVER-NM^1^^1^2
"KRN",8994,129,2,2,1,0)
^8994.021^2^2^3151215^^^^
"KRN",8994,129,2,2,1,1,0)
Identifying name for the calling application or server,
"KRN",8994,129,2,2,1,2,0)
used for logging (signon log).
"KRN",8994,129,2,"B","CLIENT-IP",1)

"KRN",8994,129,2,"B","SERVER-NM",2)

"KRN",8994,129,2,"PARAMSEQ",1,1)

"KRN",8994,129,2,"PARAMSEQ",2,2)

"KRN",8994,129,3,0)
^8994.03^18^18^3151215^^^^
"KRN",8994,129,3,1,0)
OUTPUT:
"KRN",8994,129,3,2,0)
Result(0) is the users DUZ.
"KRN",8994,129,3,3,0)
Result(1) is the user name from the .01 field.
"KRN",8994,129,3,4,0)
Result(2) is the users full name from the name standard file.
"KRN",8994,129,3,5,0)
Result(3) is the FAMILY (LAST) NAME
"KRN",8994,129,3,6,0)
Result(4) is the GIVEN (FIRST) NAME
"KRN",8994,129,3,7,0)
Result(5) is the MIDDLE NAME
"KRN",8994,129,3,8,0)
Result(6) is the PREFIX
"KRN",8994,129,3,9,0)
Result(7) is the SUFFIX
"KRN",8994,129,3,10,0)
Result(8) is the DEGREE
"KRN",8994,129,3,11,0)
Result(9) is station # of the division that the user is working in.
"KRN",8994,129,3,12,0)
Result(10) is the station # of the parent facility for the login division
"KRN",8994,129,3,13,0)
Result(11) is the station # from the KSP site parameters, the parent 
"KRN",8994,129,3,14,0)
"computer system"
"KRN",8994,129,3,15,0)
Result(12) is the signon log entry IEN
"KRN",8994,129,3,16,0)
Result(13) = # of permissible divisions
"KRN",8994,129,3,17,0)
Result(14-n) are the permissible divisions for user login, in the format:
"KRN",8994,129,3,18,0)
IEN of file 4^Station Name^Station Number^default? (1 or 0)
"KRN",8994,130,-1)
0^16
"KRN",8994,130,0)
XUS KAAJEE LOGOUT^SIGNOFF^XUSKAAJ^1^A^^^^1^^1
"KRN",8994,130,1,0)
^8994.01^2^2^3151215^^^^
"KRN",8994,130,1,1,0)
This RPC calls the LOUT^XUSCLEAN tag to mark a KAAJEE-signed-on user's
"KRN",8994,130,1,2,0)
entry in the sign-on log as signed off.
"KRN",8994,130,2,0)
^8994.02A^1^1
"KRN",8994,130,2,1,0)
SIGNON-LOG-DA^1^1^1^1
"KRN",8994,130,2,1,1,0)
^8994.021^1^1^3151215^^^^
"KRN",8994,130,2,1,1,1,0)
The DA (IEN) of the user's signon log entry.
"KRN",8994,130,2,"B","SIGNON-LOG-DA",1)

"KRN",8994,130,2,"PARAMSEQ",1,1)

"KRN",8994,130,3,0)
^8994.03^1^1^3151215^^^^
"KRN",8994,130,3,1,0)
Returns 1. The return value has no significance.
"KRN",8994,144,-1)
0^11
"KRN",8994,144,0)
XUS ALLKEYS^ALLKEYS^XUSRB^4^P^^^1^1^^1
"KRN",8994,144,1,0)
^^5^5^3151209^
"KRN",8994,144,1,1,0)
RPC ICR #6287 - API ICR #3277
"KRN",8994,144,1,2,0)
This RPC will return all the KEYS that a user holds. If the FLAG is set to
"KRN",8994,144,1,3,0)
some value the list of KEYS will be screened to only be those for J2EE
"KRN",8994,144,1,4,0)
use. The RPC was designed for FATKAAT and KAAJEE (VistALink clients) but 
"KRN",8994,144,1,5,0)
may be used by other applications.
"KRN",8994,144,2,0)
^8994.02A^2^2
"KRN",8994,144,2,1,0)
IEN^1^10^0^1
"KRN",8994,144,2,1,1,0)
^8994.021^2^2^3151209^^
"KRN",8994,144,2,1,1,1,0)
This is the IEN or DUZ of the user in question. If not passed in the RPC
"KRN",8994,144,2,1,1,2,0)
will use the current DUZ.
"KRN",8994,144,2,2,0)
FLAG^1^3^0^2
"KRN",8994,144,2,2,1,0)
^8994.021^1^1^3151209^^^^
"KRN",8994,144,2,2,1,1,0)
Not in use at this time.
"KRN",8994,144,2,"B","FLAG",2)

"KRN",8994,144,2,"B","IEN",1)

"KRN",8994,144,2,"PARAMSEQ",1,1)

"KRN",8994,144,2,"PARAMSEQ",2,2)

"KRN",8994,144,3,0)
^8994.03^3^3^3151209^^^^
"KRN",8994,144,3,1,0)
Returns -1 if failed for some reason.
"KRN",8994,144,3,2,0)
Otherwise it returns a list of the names of the Security KEYS the user
"KRN",8994,144,3,3,0)
holds.
"KRN",8994,212,-1)
0^15
"KRN",8994,212,0)
XUS KAAJEE GET USER VIA PROXY^USERINFO^XUSKAAJ1^2^R^^^^1^^1
"KRN",8994,212,1,0)
^8994.01^2^2^3151215^^^
"KRN",8994,212,1,1,0)
Returns a variety of information needed for KAAJEE logon based on the 
"KRN",8994,212,1,2,0)
ccow token
"KRN",8994,212,2,0)
^8994.02A^3^3
"KRN",8994,212,2,1,0)
CLIENT-IP^1^^1^1
"KRN",8994,212,2,1,1,0)
^^3^3^3080730^
"KRN",8994,212,2,1,1,1,0)
IP address of the client workstation used for logging (signon log) and IP 
"KRN",8994,212,2,1,1,2,0)
blocking (failed access attempts).  Also, this IP address is used to 
"KRN",8994,212,2,1,1,3,0)
validate ccow token submitted.
"KRN",8994,212,2,2,0)
SERVER-NM^1^^1^2
"KRN",8994,212,2,2,1,0)
^^2^2^3080730^
"KRN",8994,212,2,2,1,1,0)
Identifying name for the calling application or server used for logging 
"KRN",8994,212,2,2,1,2,0)
(signon log)
"KRN",8994,212,2,3,0)
CCOWTOK^1^^1^3
"KRN",8994,212,2,3,1,0)
^8994.021^1^1^3151215^^^
"KRN",8994,212,2,3,1,1,0)
Value of ccow token passed.
"KRN",8994,212,2,"B","CCOWTOK",3)

"KRN",8994,212,2,"B","CLIENT-IP",1)

"KRN",8994,212,2,"B","SERVER-NM",2)

"KRN",8994,212,2,"PARAMSEQ",1,1)

"KRN",8994,212,2,"PARAMSEQ",2,2)

"KRN",8994,212,2,"PARAMSEQ",3,3)

"KRN",8994,212,3,0)
^8994.03^20^20^3151215^^
"KRN",8994,212,3,1,0)
output is the same as the RPC named XUS FATKAAT GET USER INFO.
"KRN",8994,212,3,2,0)
  
"KRN",8994,212,3,3,0)
OUTPUT:
"KRN",8994,212,3,4,0)
 Result(0) is the users DUZ.
"KRN",8994,212,3,5,0)
 Result(1) is the user name from the .01 field.
"KRN",8994,212,3,6,0)
 Result(2) is the users full name from the name standard file.
"KRN",8994,212,3,7,0)
 Result(3) is the FAMILY (LAST) NAME
"KRN",8994,212,3,8,0)
 Result(4) is the GIVEN (FIRST) NAME
"KRN",8994,212,3,9,0)
 Result(5) is the MIDDLE NAME
"KRN",8994,212,3,10,0)
 Result(6) is the PREFIX
"KRN",8994,212,3,11,0)
 Result(7) is the SUFFIX
"KRN",8994,212,3,12,0)
 Result(8) is the DEGREE
"KRN",8994,212,3,13,0)
 Result(9) is station # of the division that the user is working in.
"KRN",8994,212,3,14,0)
 Result(10) is the station # of the parent facility for the login division
"KRN",8994,212,3,15,0)
 Result(11) is the station # from the KSP site parameters, the parent
"KRN",8994,212,3,16,0)
 "computer system" 
"KRN",8994,212,3,17,0)
 Result(12) is the signon log entry IEN 
"KRN",8994,212,3,18,0)
 Result(13) = # of permissible divisions 
"KRN",8994,212,3,19,0)
 Result(14-n) are the permissible divisions for user login, in the format:
"KRN",8994,212,3,20,0)
 IEN of file 4^Station Name^Station Number^default? (1 or 0)
"KRN",8994,213,-1)
0^13
"KRN",8994,213,0)
XUS KAAJEE GET CCOW TOKEN^CCOWIP^XUSKAAJ1^2^R^^^^1^^1
"KRN",8994,213,1,0)
^8994.01^1^1^3151215^^^
"KRN",8994,213,1,1,0)
This RPC gets a token to save in the CCOW context to aid in sign-on
"KRN",8994,213,2,0)
^8994.02A^1^1
"KRN",8994,213,2,1,0)
IP-ADDRESS^1^30^0^1
"KRN",8994,213,2,1,1,0)
^8994.021^4^4^3151215^^
"KRN",8994,213,2,1,1,1,0)
This value represents the IP address of the workstation.  Useful for J2EE
"KRN",8994,213,2,1,1,2,0)
applications that connect to VistA via the application server. If present,
"KRN",8994,213,2,1,1,3,0)
this value will be used when associating a CCOW token to the IP
"KRN",8994,213,2,1,1,4,0)
address of the client workstation
"KRN",8994,213,2,"B","IP-ADDRESS",1)

"KRN",8994,213,2,"PARAMSEQ",1,1)

"KRN",8994,332,-1)
0^5
"KRN",8994,332,0)
XUS IAM ADD USER^IAMAU^XUESSO3^2^S^^^^1^^0
"KRN",8994,332,1,0)
^^7^7^3160225^
"KRN",8994,332,1,1,0)
RPC ICR #6290 - API ICR #none
"KRN",8994,332,1,2,0)
This restricted RPC is used exclusively by the Identity and Access 
"KRN",8994,332,1,3,0)
Management (IAM) Provisioning application to add a user to the VistA NEW
"KRN",8994,332,1,4,0)
PERSON file (#200).
"KRN",8994,332,1,5,0)
 
"KRN",8994,332,1,6,0)
The XUSPF200 Security Key is required to add a user without an SSN (file
"KRN",8994,332,1,7,0)
#200 special privileges).
"KRN",8994,332,2,0)
^8994.02A^8^8
"KRN",8994,332,2,1,0)
NAME^1^35^1^1
"KRN",8994,332,2,1,1,0)
^^2^2^3150206^
"KRN",8994,332,2,1,1,1,0)
NAME field (#.01) in the NEW PERSON file (#200) to match the SubjectID in 
"KRN",8994,332,2,1,1,2,0)
the user's SAML Token.
"KRN",8994,332,2,2,0)
SECID^1^30^1^2
"KRN",8994,332,2,2,1,0)
^8994.021^2^2^3150210^^
"KRN",8994,332,2,2,1,1,0)
SECID field (#205.1) in the NEW PERSON file (#200) to match the SecID in 
"KRN",8994,332,2,2,1,2,0)
the user's SAML Token.
"KRN",8994,332,2,3,0)
EMAIL^1^50^0^3
"KRN",8994,332,2,3,1,0)
^^1^1^3150206^
"KRN",8994,332,2,3,1,1,0)
EMAIL field (#.151) in the NEW PERSON file (#200).
"KRN",8994,332,2,4,0)
ADUPN^1^50^0^4
"KRN",8994,332,2,4,1,0)
^^2^2^3150211^
"KRN",8994,332,2,4,1,1,0)
AD UPN field (#205.5) in the NEW PERSON file (#200) to match user's Active
"KRN",8994,332,2,4,1,2,0)
Directory UPN.
"KRN",8994,332,2,4,2)

"KRN",8994,332,2,5,0)
SSN^1^9^0^5
"KRN",8994,332,2,5,1,0)
^^4^4^3150206^
"KRN",8994,332,2,5,1,1,0)
SSN field (#9) in the NEW PERSON file (#200) to match the user's Social 
"KRN",8994,332,2,5,1,2,0)
Security Number or Taxpayer Identification Number. While not required to 
"KRN",8994,332,2,5,1,3,0)
provision a VistA user, not populating this field with a valid SSN could
"KRN",8994,332,2,5,1,4,0)
prevent access to some applications and data in VistA.
"KRN",8994,332,2,6,0)
DOB^1^20^0^6
"KRN",8994,332,2,6,1,0)
^^2^2^3150206^
"KRN",8994,332,2,6,1,1,0)
DOB field (#5) in the NEW PERSON file (#200) to match the user's Date of 
"KRN",8994,332,2,6,1,2,0)
Birth.
"KRN",8994,332,2,7,0)
STATION^1^20^0^7
"KRN",8994,332,2,7,1,0)
^8994.021^3^3^3150210^^
"KRN",8994,332,2,7,1,1,0)
DIVISION field (#.01) of the DIVISION multiple (#16) in the NEW PERSON 
"KRN",8994,332,2,7,1,2,0)
file (#200). The name of a Division that this user may sign on to. The 
"KRN",8994,332,2,7,1,3,0)
Division should be an active treating facility.
"KRN",8994,332,2,8,0)
AUTHCODE^1^80^1^8
"KRN",8994,332,2,8,1,0)
^8994.021^1^1^3150730^^^^
"KRN",8994,332,2,8,1,1,0)
Security Phrase for IAM Provisioning Application.
"KRN",8994,332,2,"B","ADUPN",4)

"KRN",8994,332,2,"B","AUTHCODE",8)

"KRN",8994,332,2,"B","DOB",6)

"KRN",8994,332,2,"B","EMAIL",3)

"KRN",8994,332,2,"B","NAME",1)

"KRN",8994,332,2,"B","SECID",2)

"KRN",8994,332,2,"B","SSN",5)

"KRN",8994,332,2,"B","STATION",7)

"KRN",8994,332,2,"PARAMSEQ",1,1)

"KRN",8994,332,2,"PARAMSEQ",2,2)

"KRN",8994,332,2,"PARAMSEQ",3,3)

"KRN",8994,332,2,"PARAMSEQ",4,4)

"KRN",8994,332,2,"PARAMSEQ",5,5)

"KRN",8994,332,2,"PARAMSEQ",6,6)

"KRN",8994,332,2,"PARAMSEQ",7,7)

"KRN",8994,332,2,"PARAMSEQ",8,8)

"KRN",8994,332,3,0)
^^3^3^3150730^
"KRN",8994,332,3,1,0)
Fail    R(0)               = "-1^Number of Errors"
"KRN",8994,332,3,2,0)
        R(1) through R(n)  = "Error Message"
"KRN",8994,332,3,3,0)
Success R(0)               = "DUZ^STATION"
"KRN",8994,333,-1)
0^4
"KRN",8994,333,0)
XUS IAM EDIT USER^IAMEU^XUESSO3^2^S^^^^1^^0
"KRN",8994,333,1,0)
^^11^11^3151209^
"KRN",8994,333,1,1,0)
RPC ICR #6291 - API ICR #none
"KRN",8994,333,1,2,0)
This restricted RPC is used exclusively by the Identity and Access 
"KRN",8994,333,1,3,0)
Management (IAM) Provisioning application to edit an existing user in the
"KRN",8994,333,1,4,0)
VistA NEW PERSON file (#200).
"KRN",8994,333,1,5,0)
 
"KRN",8994,333,1,6,0)
The XUSHOWSSN Security Key is required to edit Personally Identifiable
"KRN",8994,333,1,7,0)
Information (PII) such as Social Security Number (SSN) or Date of Birth
"KRN",8994,333,1,8,0)
(DOB).
"KRN",8994,333,1,9,0)
 
"KRN",8994,333,1,10,0)
The XUSPF200 Security Key is required to edit a user without an SSN (file
"KRN",8994,333,1,11,0)
#200 special privileges).
"KRN",8994,333,2,0)
^8994.02A^2^2
"KRN",8994,333,2,1,0)
INARRY^2^240^1^1
"KRN",8994,333,2,1,1,0)
^^13^13^3150707^
"KRN",8994,333,2,1,1,1,0)
INARRY("SECID") = SecID (not edited, but used to identify entry to be 
"KRN",8994,333,2,1,1,2,0)
                  edited)
"KRN",8994,333,2,1,1,3,0)
INARRY("LASTNAME") = User NAME is concatenation of "LASTNAME,FIRSTNAME 
"KRN",8994,333,2,1,1,4,0)
                     MIDDLENAME SUFFIX"
"KRN",8994,333,2,1,1,5,0)
INARRY("FIRSTNAME")
"KRN",8994,333,2,1,1,6,0)
INARRY("MIDDLENAME")
"KRN",8994,333,2,1,1,7,0)
INARRY("SUFFIX")
"KRN",8994,333,2,1,1,8,0)
INARRY("ORGANIZATIONNAME") = SUBJECT ORGANIZATION (Organization Name)
"KRN",8994,333,2,1,1,9,0)
INARRY("ORGANIZATIONID") = SUBJECT ORGANIZATION ID (Organization ID)
"KRN",8994,333,2,1,1,10,0)
INARRY("EMAIL") = EMAIL ADDRESS (E-mail Address)
"KRN",8994,333,2,1,1,11,0)
INARRY("ADUPN") = ADUPN (Active Directory UPN)
"KRN",8994,333,2,1,1,12,0)
INARRY("SSN") = SSN (Social Security Number) 
"KRN",8994,333,2,1,1,13,0)
INARRY("DOB) = DOB (Date of Birth)
"KRN",8994,333,2,2,0)
AUTHCODE^1^80^1^2
"KRN",8994,333,2,2,1,0)
^8994.021^1^1^3150629^^^^
"KRN",8994,333,2,2,1,1,0)
Security Phrase for IAM Provisioning Application.
"KRN",8994,333,2,"B","AUTHCODE",2)

"KRN",8994,333,2,"B","INARRY",1)

"KRN",8994,333,2,"PARAMSEQ",1,1)

"KRN",8994,333,2,"PARAMSEQ",2,2)

"KRN",8994,333,3,0)
^^3^3^3150629^
"KRN",8994,333,3,1,0)
Success RES(0)=DUZ of NEW PERSON file entry that was edited
"KRN",8994,333,3,2,0)
Fail    RES(0)="-1^Number of Errors"
"KRN",8994,333,3,3,0)
        RES(1) through Y(n)="Error Message"
"KRN",8994,334,-1)
0^2
"KRN",8994,334,0)
XUS IAM FIND USER^IAMFU^XUESSO3^2^S^^^^1^^0
"KRN",8994,334,1,0)
^^9^9^3151209^
"KRN",8994,334,1,1,0)
RPC ICR #6288 - API ICR #none
"KRN",8994,334,1,2,0)
This restricted RPC is used exclusively by the Identity and Access 
"KRN",8994,334,1,3,0)
Management (IAM) Provisioning application to find a list of users that 
"KRN",8994,334,1,4,0)
satisfy a collection of input criteria.
"KRN",8994,334,1,5,0)
 
"KRN",8994,334,1,6,0)
One or more of the input array values must be set by the calling 
"KRN",8994,334,1,7,0)
application. The XUSHOWSSN Security Key is required to do lookups using 
"KRN",8994,334,1,8,0)
Personally Identifiable Information (PII) such as Social Security Number 
"KRN",8994,334,1,9,0)
(SSN) or Date of Birth (DOB).
"KRN",8994,334,2,0)
^8994.02A^6^6
"KRN",8994,334,2,1,0)
NAME^1^35^0^1
"KRN",8994,334,2,1,1,0)
^8994.021^1^1^3150128^^
"KRN",8994,334,2,1,1,1,0)
Search on user name.
"KRN",8994,334,2,2,0)
SSN^1^9^^2
"KRN",8994,334,2,2,1,0)
^^2^2^3150210^
"KRN",8994,334,2,2,1,1,0)
Search on user Social Security Number (SSN). The user calling this RPC 
"KRN",8994,334,2,2,1,2,0)
must hold the XUSHOWSSN Security Key to search using SSN.
"KRN",8994,334,2,3,0)
DOB^1^15^^3
"KRN",8994,334,2,3,1,0)
^^2^2^3150210^
"KRN",8994,334,2,3,1,1,0)
Search on user Date of Birth (DOB). The user calling this RPC must hold
"KRN",8994,334,2,3,1,2,0)
the XUSHOWSSN Security Key to search using DOB.
"KRN",8994,334,2,4,0)
ADUPN^1^50^^4
"KRN",8994,334,2,4,1,0)
^8994.021^1^1^3150206^^
"KRN",8994,334,2,4,1,1,0)
Search on user Active Directory UPN.
"KRN",8994,334,2,5,0)
SECID^1^30^^5
"KRN",8994,334,2,5,1,0)
^8994.021^1^1^3150210^^^
"KRN",8994,334,2,5,1,1,0)
Search on user Security ID.
"KRN",8994,334,2,6,0)
AUTHCODE^1^80^1^6
"KRN",8994,334,2,6,1,0)
^8994.021^1^1^3150729^^^
"KRN",8994,334,2,6,1,1,0)
Security Phrase for IAM Provisioning Application.
"KRN",8994,334,2,"B","ADUPN",4)

"KRN",8994,334,2,"B","AUTHCODE",6)

"KRN",8994,334,2,"B","DOB",3)

"KRN",8994,334,2,"B","NAME",1)

"KRN",8994,334,2,"B","SECID",5)

"KRN",8994,334,2,"B","SSN",2)

"KRN",8994,334,2,"PARAMSEQ",1,1)

"KRN",8994,334,2,"PARAMSEQ",2,2)

"KRN",8994,334,2,"PARAMSEQ",3,3)

"KRN",8994,334,2,"PARAMSEQ",4,4)

"KRN",8994,334,2,"PARAMSEQ",5,5)

"KRN",8994,334,2,"PARAMSEQ",6,6)

"KRN",8994,334,3,0)
^^3^3^3150729^
"KRN",8994,334,3,1,0)
Fail    R(0)="-1^Error Message"
"KRN",8994,334,3,2,0)
Success R(0)=total number of entries found, from "0" to "n".
"KRN",8994,334,3,3,0)
        R(1) through R(n)="DUZ^Name^Name Components^SSN^Dob^AD UPN^SecID"
"KRN",8994,337,-1)
0^3
"KRN",8994,337,0)
XUS IAM DISPLAY USER^IAMDU^XUESSO3^2^S^^^^1^^0
"KRN",8994,337,1,0)
^^7^7^3160225^
"KRN",8994,337,1,1,0)
RPC ICE #6289 - API ICR #none
"KRN",8994,337,1,2,0)
This restricted RPC is used exclusively by the Identity and Access 
"KRN",8994,337,1,3,0)
Management (IAM) Provisioning application to display a VistA user.
"KRN",8994,337,1,4,0)
 
"KRN",8994,337,1,5,0)
The XUSHOWSSN Security Key is required to display Personally Identifiable
"KRN",8994,337,1,6,0)
Information (PII) such as Social Security Number (SSN) or Date of Birth
"KRN",8994,337,1,7,0)
(DOB).
"KRN",8994,337,2,0)
^8994.02A^2^2
"KRN",8994,337,2,1,0)
DISPDUZ^1^20^1^1
"KRN",8994,337,2,1,1,0)
^8994.021^1^1^3150210^^^
"KRN",8994,337,2,1,1,1,0)
DUZ (IEN) of user to be displayed.
"KRN",8994,337,2,2,0)
AUTHCODE^1^80^1^2
"KRN",8994,337,2,2,1,0)
^8994.021^1^1^3150722^^^^
"KRN",8994,337,2,2,1,1,0)
Security Phrase for IAM Provisioning Application.
"KRN",8994,337,2,"B","AUTHCODE",2)

"KRN",8994,337,2,"B","DISPDUZ",1)

"KRN",8994,337,2,"PARAMSEQ",1,1)

"KRN",8994,337,2,"PARAMSEQ",2,2)

"KRN",8994,337,3,0)
^^36^36^3150722^
"KRN",8994,337,3,1,0)
Fail
"KRN",8994,337,3,2,0)
  R(0) ="-1^Error Message"
"KRN",8994,337,3,3,0)
Success
"KRN",8994,337,3,4,0)
  R(0) = 1
"KRN",8994,337,3,5,0)
  R("NAME") = NAME
"KRN",8994,337,3,6,0)
  R("LASTNAME") = Family Name
"KRN",8994,337,3,7,0)
  R("FIRSTNAME") = Given Name
"KRN",8994,337,3,8,0)
  R("MIDDLENAME") = Middle Name
"KRN",8994,337,3,9,0)
  R("SUFFIX") = Suffix(es)
"KRN",8994,337,3,10,0)
  R("INITIAL") = INITIAL
"KRN",8994,337,3,11,0)
  R("TITLE") = TITLE
"KRN",8994,337,3,12,0)
  R("NICK_NAME") = NICK NAME
"KRN",8994,337,3,13,0)
  R("SSN") = SSN (<Hidden> if caller does not hold XUSHOWSSN key)
"KRN",8994,337,3,14,0)
  R("DOB") = DOB (<Hidden> if caller does not hold XUSHOWSSN key)
"KRN",8994,337,3,15,0)
  R("DEGREE") = DEGREE
"KRN",8994,337,3,16,0)
  R("MAIL_CODE") = MAIL CODE
"KRN",8994,337,3,17,0)
  R("STATUS") = $$ACTIVE^XUSER(DISPDUZ)
"KRN",8994,337,3,18,0)
  R("DISUSER") = DISUSER
"KRN",8994,337,3,19,0)
  R("TERMINATION_DATE") = TERMINATION DATE
"KRN",8994,337,3,20,0)
  R("TERMINATION_REASON") = TERMINATION REASON
"KRN",8994,337,3,21,0)
  R("PRIMARY_MENU_OPTION") = PRIMARY MENU OPTION
"KRN",8994,337,3,22,0)
  R("SECONDARY_MENU_OPTION",0) = SECONDARY MENU OPTION (# of entries)
"KRN",8994,337,3,23,0)
  R("SECONDARY_MENU_OPTION",1) to R("SECONDARY_MENU_OPTION",n) = entries
"KRN",8994,337,3,24,0)
  R("FILE_MANAGER_ACCESS_CODE") = FILE MANAGER ACCESS CODE
"KRN",8994,337,3,25,0)
  R("DIVISION",0) = DIVISION (number of entries)
"KRN",8994,337,3,26,0)
  R("DIVISION",1) to R("DIVISION",n) = DIVISION entries
"KRN",8994,337,3,27,0)
  R("SERVICE_SECTION") = SERVICE/SECTION
"KRN",8994,337,3,28,0)
  R("SUBJECT_ALTERNATIVE_NAME") = SUBJECT ALTERNATIVE NAME
"KRN",8994,337,3,29,0)
  R("SECID") = SECID
"KRN",8994,337,3,30,0)
  R("ORGANIZATION_NAME") = SUBJECT ORGANIZATION
"KRN",8994,337,3,31,0)
  R("ORGANIZATION_ID") = SUBJECT ORGANIZATION ID
"KRN",8994,337,3,32,0)
  R("UNIQUE_USER_ID") = UNIQUE USER ID
"KRN",8994,337,3,33,0)
  R("NETWORK_USER_NAME") = NETWORK USERNAME
"KRN",8994,337,3,34,0)
  R("ADUPN") = AD UPN
"KRN",8994,337,3,35,0)
  R("EMAIL") = EMAIL ADDRESS
"KRN",8994,337,3,36,0)
  R("GENDER") = SEX (M/F)
"KRN",8994,338,-1)
0^1
"KRN",8994,338,0)
XUS ESSO VALIDATE^ESSO^XUESSO4^2^R^^^^1^^0
"KRN",8994,338,1,0)
^^3^3^3151209^
"KRN",8994,338,1,1,0)
RPC ICR #6295 - API ICR #none
"KRN",8994,338,1,2,0)
This API/RPC uses the VA Identity and Access Management (IAM) SAML token
"KRN",8994,338,1,3,0)
definition version 1.2 attributes from a SAML token for user sign-on.
"KRN",8994,338,2,0)
^8994.02A^1^1
"KRN",8994,338,2,1,0)
DOC^1^30^1^1
"KRN",8994,338,2,1,1,0)
^^4^4^3150305^
"KRN",8994,338,2,1,1,1,0)
Input:   DOC = Closed reference to global root containing XML document 
"KRN",8994,338,2,1,1,2,0)
               (loaded STS SAML Token). See $$EN^MXMLDOM instructions in
"KRN",8994,338,2,1,1,3,0)
               the VistA Kernel Developers Guide for required format of
"KRN",8994,338,2,1,1,4,0)
               the DOC global.
"KRN",8994,338,2,"B","DOC",1)

"KRN",8994,338,2,"PARAMSEQ",1,1)

"KRN",8994,338,3,0)
^8994.03^7^7^3150305^^^^
"KRN",8994,338,3,1,0)
R(0) = DUZ if sign-on was OK, zero if not OK.
"KRN",8994,338,3,2,0)
R(1) = (0=OK, 1,2...=Can't sign on for some reason).
"KRN",8994,338,3,3,0)
R(2) = Verify Code needs changing.
"KRN",8994,338,3,4,0)
R(3) = Message.
"KRN",8994,338,3,5,0)
R(4) = 0
"KRN",8994,338,3,6,0)
R(5) = count of the number of lines of text, zero if none.
"KRN",8994,338,3,7,0)
R(5+n) = message text.
"KRN",8994,339,-1)
0^6
"KRN",8994,339,0)
XUS IAM BIND USER^IAMBU^XUESSO4^1^S^^^^1^^0
"KRN",8994,339,1,0)
^^5^5^3151209^
"KRN",8994,339,1,1,0)
RPC ICR #6294 - API ICR #none
"KRN",8994,339,1,2,0)
This restricted RPC is used exclusively by the Identity and Access 
"KRN",8994,339,1,3,0)
Management (IAM) Binding application to set the Security ID (SecID) and 
"KRN",8994,339,1,4,0)
Active Directory UPN (ADUPN) in the VistA NEW PERSON file (#200) for
"KRN",8994,339,1,5,0)
Single Sign-On Internal (SSOi).
"KRN",8994,339,2,0)
^8994.02A^3^3
"KRN",8994,339,2,1,0)
SECID^1^40^1^1
"KRN",8994,339,2,1,1,0)
^^1^1^3150311^
"KRN",8994,339,2,1,1,1,0)
Unique Security ID [SecID, assigned by Identity and Access Management]
"KRN",8994,339,2,2,0)
AUTHCODE^1^80^1^2
"KRN",8994,339,2,2,1,0)
^8994.021^1^1^3151203^^^
"KRN",8994,339,2,2,1,1,0)
Security Phrase for IAM Binding Application
"KRN",8994,339,2,3,0)
ADUPN^1^30^1^3
"KRN",8994,339,2,3,1,0)
^8994.021^1^1^3151203^^
"KRN",8994,339,2,3,1,1,0)
Active Directory UPN
"KRN",8994,339,2,"B","ADUPN",3)

"KRN",8994,339,2,"B","AUTHCODE",2)

"KRN",8994,339,2,"B","SECID",1)

"KRN",8994,339,2,"PARAMSEQ",1,1)

"KRN",8994,339,2,"PARAMSEQ",2,2)

"KRN",8994,339,2,"PARAMSEQ",3,3)

"KRN",8994,339,3,0)
^8994.03^2^2^3151203^^^
"KRN",8994,339,3,1,0)
Return: Fail    Y = "-1^Error Message"
"KRN",8994,339,3,2,0)
        Success Y = DUZ
"KRN",8994,342,-1)
0^7
"KRN",8994,342,0)
XUS IAM TERMINATE USER^IAMTU^XUESSO3^2^R^^^^1^^0
"KRN",8994,342,1,0)
^8994.01^3^3^3150722^^
"KRN",8994,342,1,1,0)
This restricted RPC is used exclusively by the Identity and Access 
"KRN",8994,342,1,2,0)
Management (IAM) Provisioning application to terminate an existing user 
"KRN",8994,342,1,3,0)
in the VistA NEW PERSON file (#200).
"KRN",8994,342,2,0)
^8994.02A^4^4
"KRN",8994,342,2,1,0)
SECID^1^30^1^1
"KRN",8994,342,2,1,1,0)
^^2^2^3150707^
"KRN",8994,342,2,1,1,1,0)
SECID field (#205.1) in the NEW PERSON file (#200) to match the SecID in 
"KRN",8994,342,2,1,1,2,0)
the user's SAML Token.
"KRN",8994,342,2,2,0)
TERMDATE^1^20^1^2
"KRN",8994,342,2,2,1,0)
^^1^1^3150707^
"KRN",8994,342,2,2,1,1,0)
TERMINATION DATE field (#9.2) in the NEW PERSON file (#200).
"KRN",8994,342,2,3,0)
TERMRESN^1^45^1^3
"KRN",8994,342,2,3,1,0)
^8994.021^1^1^3150707^^
"KRN",8994,342,2,3,1,1,0)
Termination Reason field (#9.4) in the NEW PERSON file (#200).
"KRN",8994,342,2,4,0)
AUTHCODE^1^80^1^4
"KRN",8994,342,2,4,1,0)
^8994.021^1^1^3150722^^
"KRN",8994,342,2,4,1,1,0)
Security Phrase for IAM Provisioning Application.
"KRN",8994,342,2,"B","AUTHCODE",4)

"KRN",8994,342,2,"B","SECID",1)

"KRN",8994,342,2,"B","TERMDATE",2)

"KRN",8994,342,2,"B","TERMRESN",3)

"KRN",8994,342,2,"PARAMSEQ",1,1)

"KRN",8994,342,2,"PARAMSEQ",2,2)

"KRN",8994,342,2,"PARAMSEQ",3,3)

"KRN",8994,342,2,"PARAMSEQ",4,4)

"KRN",8994,342,3,0)
^^3^3^3150722^
"KRN",8994,342,3,1,0)
Fail    R(0) = "-1^Number of Errors"
"KRN",8994,342,3,2,0)
        R(1) through RES(n)="Error Message"
"KRN",8994,342,3,3,0)
Success R(0) = 1
"KRN",8994,343,-1)
0^8
"KRN",8994,343,0)
XUS IAM REACTIVATE USER^IAMRU^XUESSO3^2^S^^^^1^^0
"KRN",8994,343,1,0)
^^4^4^3151209^
"KRN",8994,343,1,1,0)
RPC ICR #6293 - API ICR #none
"KRN",8994,343,1,2,0)
This restricted RPC is used exclusively by the Identity and Access 
"KRN",8994,343,1,3,0)
Management (IAM) Provisioning application to reactivate an existing user 
"KRN",8994,343,1,4,0)
in the VistA NEW PERSON file (#200).
"KRN",8994,343,2,0)
^8994.02A^2^2
"KRN",8994,343,2,1,0)
SECID^1^30^1^1
"KRN",8994,343,2,1,1,0)
^^2^2^3150707^
"KRN",8994,343,2,1,1,1,0)
SECID field (#205.1) in the NEW PERSON file (#200) to match the SecID in 
"KRN",8994,343,2,1,1,2,0)
the user's SAML Token.
"KRN",8994,343,2,2,0)
AUTHCODE^1^80^1^2
"KRN",8994,343,2,2,1,0)
^8994.021^1^1^3150722^^
"KRN",8994,343,2,2,1,1,0)
Security Phrase for IAM Provisioning Application.
"KRN",8994,343,2,"B","AUTHCODE",2)

"KRN",8994,343,2,"B","SECID",1)

"KRN",8994,343,2,"PARAMSEQ",1,1)

"KRN",8994,343,2,"PARAMSEQ",2,2)

"KRN",8994,343,3,0)
^^3^3^3150722^
"KRN",8994,343,3,1,0)
Fail    R(0) = "-1^Number of Errors"
"KRN",8994,343,3,2,0)
        R(1) through RES(n) = "Error Message"
"KRN",8994,343,3,3,0)
Success R(0) = 1
"KRN",8994,347,-1)
0^17
"KRN",8994,347,0)
XUS BSE TOKEN^BSETOKEN^XUSBSE1^1^S^^^^1^^1
"KRN",8994,347,1,0)
^^5^5^3160105^
"KRN",8994,347,1,1,0)
RPC ICR #TBD - API ICR #none
"KRN",8994,347,1,2,0)
This API/RPC returns a string from the current user authentication that 
"KRN",8994,347,1,3,0)
can be used to authenticate the user on a visited system. The application
"KRN",8994,347,1,4,0)
is identified by a security phrase that, when hashed, matches the stored
"KRN",8994,347,1,5,0)
hash of an authorized application in the REMOTE APPLICATION file (#8994.5)
"KRN",8994,347,2,0)
^8994.02A^1^1
"KRN",8994,347,2,1,0)
XPHRASE^1^90^1^1
"KRN",8994,347,2,1,1,0)
^^2^2^3160105^
"KRN",8994,347,2,1,1,1,0)
Input:   XPHRASE = Security phrase to be used to authenticate and identify
"KRN",8994,347,2,1,1,2,0)
the application.
"KRN",8994,347,2,"B","XPHRASE",1)

"KRN",8994,347,2,"PARAMSEQ",1,1)

"KRN",8994,347,3,0)
^8994.03^3^3^3160105^^
"KRN",8994,347,3,1,0)
RET = Complete BSE login string (no processing required by middleware or 
"KRN",8994,347,3,2,0)
client) to be passed to the XWBUSRNM input parameter of the XUS SIGNON 
"KRN",8994,347,3,3,0)
SETUP remote procedure.
"MBREQ")
0
"ORD",0,9.8)
9.8;;1;RTNF^XPDTA;RTNE^XPDTA
"ORD",0,9.8,0)
ROUTINE
"ORD",5,.4)
.4;5;;;EDEOUT^DIFROMSO(.4,DA,"",XPDA);FPRE^DIFROMSI(.4,"",XPDA);EPRE^DIFROMSI(.4,DA,$E("N",$
G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.4,DA,"",XPDA);DEL^DIFROMSK(.4,"",%)
"ORD",5,.4,0)
PRINT TEMPLATE
"ORD",16,8994)
8994;16;1;;;;;;;RPCDEL^XPDIA1
"ORD",16,8994,0)
REMOTE PROCEDURE
"ORD",18,19)
19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA
"ORD",18,19,0)
OPTION
"PKG",3,-1)
1^1
"PKG",3,0)
KERNEL^XU^SIGN-ON, SECURITY, MENU DRIVER, DEVICES, TASKMAN^
"PKG",3,22,0)
^9.49I^1^1
"PKG",3,22,1,0)
8.0^3090706^3090706^6
"PKG",3,22,1,"PAH",1,0)
659^3160308
"PKG",3,22,1,"PAH",1,1,0)
^^8^8^3160308
"PKG",3,22,1,"PAH",1,1,1,0)
This patch provides enhancements needed to implement Single Sign-On 
"PKG",3,22,1,"PAH",1,1,2,0)
Internal (SSOi) for identification and authentication of users into VistA.
"PKG",3,22,1,"PAH",1,1,3,0)
 
"PKG",3,22,1,"PAH",1,1,4,0)
The use of these utilities are expected to improve security and auditing
"PKG",3,22,1,"PAH",1,1,5,0)
capabilities in accordance with VA Handbook 6500 Appendix F and revision 4
"PKG",3,22,1,"PAH",1,1,6,0)
of NIST SP 800-53. As required by FIPS 199 and using guidance from NIST SP
"PKG",3,22,1,"PAH",1,1,7,0)
800-60, the recommended security categorization for these applications is
"PKG",3,22,1,"PAH",1,1,8,0)
HIGH.
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")

"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
NO
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
NO
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"RTN")
19
"RTN","XLFNSLK")
0^27^B39616756^B44384655
"RTN","XLFNSLK",1,0)
XLFNSLK ;ISF/RWF,ISD/HGW - Calling a DNS server for name lookup ;12/08/15  12:44
"RTN","XLFNSLK",2,0)
 ;;8.0;KERNEL;**142,151,425,638,659**;Jul 10, 1995;Build 22
"RTN","XLFNSLK",3,0)
 ;Per VA Directive 6402, this routine should not be modified.
"RTN","XLFNSLK",4,0)
 ;
"RTN","XLFNSLK",5,0)
 Q
"RTN","XLFNSLK",6,0)
TEST ;Test entry
"RTN","XLFNSLK",7,0)
 N XNAME
"RTN","XLFNSLK",8,0)
 R !,"Enter an IP address to lookup: www.DNS   //",XNAME:DTIME S:XNAME="" XNAME="www.DNS   " 
Q:XNAME["^"
"RTN","XLFNSLK",9,0)
 W !!,"Looking up IPv4 address: ",XNAME
"RTN","XLFNSLK",10,0)
 W !,?5,XNAME,". > ",$$ADDRESS(XNAME,"A")
"RTN","XLFNSLK",11,0)
 W !!,"Looking up IPv6 address: ",XNAME
"RTN","XLFNSLK",12,0)
 W !,?5,XNAME,". > ",$$ADDRESS(XNAME,"AAAA")
"RTN","XLFNSLK",13,0)
 W !
"RTN","XLFNSLK",14,0)
 Q
"RTN","XLFNSLK",15,0)
 ;
"RTN","XLFNSLK",16,0)
HOST(IP) ;Get a host name from an IP address
"RTN","XLFNSLK",17,0)
 ;ZEXCEPT: AddrToHostName,INetInfo,TextAddrToBinary ;Kernel exemption for Cache Objects
"RTN","XLFNSLK",18,0)
 N X,Y
"RTN","XLFNSLK",19,0)
 I $$VERSION^%ZOSV(1)["Cache" D  Q Y
"RTN","XLFNSLK",20,0)
 . S X=$SYSTEM.INetInfo.TextAddrToBinary(IP)
"RTN","XLFNSLK",21,0)
 . S Y=$SYSTEM.INetInfo.AddrToHostName(X)
"RTN","XLFNSLK",22,0)
 ;Enter code for non-Cache systems here:
"RTN","XLFNSLK",23,0)
 Q ""
"RTN","XLFNSLK",24,0)
 ;
"RTN","XLFNSLK",25,0)
ADDRESS(N,T) ;Get a IP address from a name
"RTN","XLFNSLK",26,0)
 ;ZEXCEPT: HostNameToAddr,INetInfo ;Kernel exemption for Cache Objects
"RTN","XLFNSLK",27,0)
 N X,XLF,Y,I S XLF="",Y=0
"RTN","XLFNSLK",28,0)
 I $$VERSION^XLFIPV S T=$G(T,"AAAA")
"RTN","XLFNSLK",29,0)
 E  S T=$G(T,"A") ; change default to "A" if VistA has IPv6 disabled
"RTN","XLFNSLK",30,0)
 I ($$VERSION^%ZOSV(1)["Cache")&((T="A")!(T="AAAA")) D  Q Y
"RTN","XLFNSLK",31,0)
 . I T="AAAA" D
"RTN","XLFNSLK",32,0)
 . . S X=$SYSTEM.INetInfo.HostNameToAddr(N,2,0) ;Get IPv6 address
"RTN","XLFNSLK",33,0)
 . . S Y=$$FORCEIP6^XLFIPV(X) ;Format IPv6 address
"RTN","XLFNSLK",34,0)
 . I ($P(Y,":")="0000")!(T="A") S Y=$SYSTEM.INetInfo.HostNameToAddr(N,1,0) ;Get IPv4 address
"RTN","XLFNSLK",35,0)
 ;Non-cache systems and lookups other than "A" or "AAAA"
"RTN","XLFNSLK",36,0)
 D NS(.XLF,N,T)
"RTN","XLFNSLK",37,0)
 S Y="" F I=1:1:XLF("ANCOUNT") S:$D(XLF("AN"_I_"DATA")) Y=Y_XLF("AN"_I_"DATA")_","
"RTN","XLFNSLK",38,0)
 Q $E(Y,1,$L(Y)-1)
"RTN","XLFNSLK",39,0)
 ;
"RTN","XLFNSLK",40,0)
MAIL(RET,N) ;Get the MX address for a domain
"RTN","XLFNSLK",41,0)
 ;RET is the return array
"RTN","XLFNSLK",42,0)
 N XLF,Y,I,T S XLF="",T="MX"
"RTN","XLFNSLK",43,0)
 D NS(.XLF,N,T)
"RTN","XLFNSLK",44,0)
 S RET=0,I=0 F  S I=$O(XLF("P",I)) Q:I'>0  D
"RTN","XLFNSLK",45,0)
 . S N=XLF("P",I),RET(I)=N_"^"_$G(XLF("B",N)),RET=RET+1
"RTN","XLFNSLK",46,0)
 Q
"RTN","XLFNSLK",47,0)
 ;
"RTN","XLFNSLK",48,0)
NS(XL,NAME,QTYPE,XLFLOG) ;NAME LOOKUP
"RTN","XLFNSLK",49,0)
 ;XL is the return array, NAME is the name to lookup,
"RTN","XLFNSLK",50,0)
 ;QTYPE is type of lookup, XLFLOG is a debug array returned.
"RTN","XLFNSLK",51,0)
 N RI,DNS,CNT,POP N:'$D(XLFLOG) XLFLOG S XL("ANCOUNT")=0,CNT=1
"RTN","XLFNSLK",52,0)
 D SAVEDEV
"RTN","XLFNSLK",53,0)
NS2 ;
"RTN","XLFNSLK",54,0)
 S DNS=$$GETDNS(CNT) I DNS="" G EXIT
"RTN","XLFNSLK",55,0)
 D LOG("Call server: "_DNS)
"RTN","XLFNSLK",56,0)
 D CALL^%ZISTCP(DNS,53) I POP S CNT=CNT+1 G NS2
"RTN","XLFNSLK",57,0)
 D LOG("Got connection, Send message")
"RTN","XLFNSLK",58,0)
 D BUILD(NAME,$G(QTYPE,"AAAA")),LOG("Wait for reply")  ; Uses "AAAA" type for IPv6 if QTYPE is not 
defined
"RTN","XLFNSLK",59,0)
 ;Close part of READ
"RTN","XLFNSLK",60,0)
 D READ,DECODE
"RTN","XLFNSLK",61,0)
 D RESDEV,LOG("Returned question: "_$G(XL("QD1NAME")))
"RTN","XLFNSLK",62,0)
 Q
"RTN","XLFNSLK",63,0)
EXIT D RESDEV
"RTN","XLFNSLK",64,0)
 Q
"RTN","XLFNSLK",65,0)
 ;
"RTN","XLFNSLK",66,0)
BUILD(Y,T) ;BUILD A QUERY
"RTN","XLFNSLK",67,0)
 ; ID,PARAM,#of?, #ofA, #of Auth, #of add,
"RTN","XLFNSLK",68,0)
 N X,%,MSG,I
"RTN","XLFNSLK",69,0)
 S X=" M"_$C(1,0)_$C(0,1)_$C(0,0)_$C(0,0)_$C(0,0) ;Header
"RTN","XLFNSLK",70,0)
 I $E(Y,$L(Y))'="." S:$E(Y,$L(Y))'="." Y=Y_"."
"RTN","XLFNSLK",71,0)
 F I=1:1:$L(Y,".") S %=$P(Y,".",I) S:$L(%) X=X_$C($L(%))_% ;FQDN Address
"RTN","XLFNSLK",72,0)
 S X=X_$C(0) ;End of FQDN address
"RTN","XLFNSLK",73,0)
 ;Type A=1, NS=2, CNAME=5, MX=15, AAAA=28
"RTN","XLFNSLK",74,0)
 S MSG=X_$C(0,$$TYPECODE(T))_$C(0,1) ;type and class
"RTN","XLFNSLK",75,0)
 D LOG("msg: "_MSG)
"RTN","XLFNSLK",76,0)
 U IO S %=$L(MSG) W $C(%\256,%#256)_MSG,!
"RTN","XLFNSLK",77,0)
 Q
"RTN","XLFNSLK",78,0)
READ ;
"RTN","XLFNSLK",79,0)
 ;ZEXCEPT: I,RI,XL ;Global variables within this routine
"RTN","XLFNSLK",80,0)
 N L1,L2,X,$ET S $ET="G RDERR" K RI S RI=0
"RTN","XLFNSLK",81,0)
 U IO R L1#2:20 I '$T D LOG("Time-out") G RDERR
"RTN","XLFNSLK",82,0)
 S RI=$A(L1,1)*256+$A(L1,2) ;get msg length
"RTN","XLFNSLK",83,0)
 F I=1:1:6 R L2#2:20 Q:'$T  S 
XL($P("ID^CODE^QDCOUNT^ANCOUNT^NSCOUNT^ARCOUNT","^",I))=$S(I>2:$$WBN(L2),I=2:$$BIN16(L
2),1:L2)
"RTN","XLFNSLK",84,0)
 I '$T D LOG("Time-out") G RDERR
"RTN","XLFNSLK",85,0)
 D LOG("Return msg length: "_RI)
"RTN","XLFNSLK",86,0)
 F I=13:1:RI U IO R *X:20 Q:'$T  S RI(I)=X ;or use X#1 and $A(X)
"RTN","XLFNSLK",87,0)
RDERR ;End of read
"RTN","XLFNSLK",88,0)
 D CLOSE^%ZISTCP
"RTN","XLFNSLK",89,0)
 Q
"RTN","XLFNSLK",90,0)
DECODE ;
"RTN","XLFNSLK",91,0)
 ;ZEXCEPT: XL ;Global variable within this routine
"RTN","XLFNSLK",92,0)
 N I,IX,X,Y,Z,NN,NN2 Q:RI'>7
"RTN","XLFNSLK",93,0)
 I $G(XL("ID"))'=" M" S XL("ERR")="Bad Response" D LOG(XL("ERR")) Q
"RTN","XLFNSLK",94,0)
 ;Decode the header
"RTN","XLFNSLK",95,0)
 S 
Z=XL("CODE"),XL("QR")=$E(Z,1),XL("Opcode")=$E(Z,2,5),XL("AA")=$E(Z,6),XL("TC")=$E(Z,7),XL("RD")=$E(
Z,8),XL("RA")=$E(Z,9),XL("RCODE")=$E(Z,13,16)
"RTN","XLFNSLK",96,0)
 ;The Question section
"RTN","XLFNSLK",97,0)
 S IX=13
"RTN","XLFNSLK",98,0)
 F NN2=1:1:XL("QDCOUNT") D QD("QD"_NN2)
"RTN","XLFNSLK",99,0)
 F NN="AN","NS","AR" I $G(XL(NN_"COUNT")) F NN2=1:1:XL(NN_"COUNT") D RR(NN_NN2)
"RTN","XLFNSLK",100,0)
 Q
"RTN","XLFNSLK",101,0)
 ;
"RTN","XLFNSLK",102,0)
QD(NSP) ;Decode the Question section
"RTN","XLFNSLK",103,0)
 ;ZEXCEPT: IX,RI,XL ;Global variables within this routine
"RTN","XLFNSLK",104,0)
 N Y
"RTN","XLFNSLK",105,0)
 S Y="",IX=IX+$$NAME(IX,.Y,1),XL(NSP_"NAME")=Y
"RTN","XLFNSLK",106,0)
 S XL(NSP_"TYPE")=$$BN(RI(IX),RI(IX+1)),IX=IX+2
"RTN","XLFNSLK",107,0)
 S XL(NSP_"CLASS")=$$BN(RI(IX),RI(IX+1)),IX=IX+2
"RTN","XLFNSLK",108,0)
 Q
"RTN","XLFNSLK",109,0)
RR(NSP) ;
"RTN","XLFNSLK",110,0)
 ;ZEXCEPT: IX,RI,X,XL ;Global variables within this routine
"RTN","XLFNSLK",111,0)
 N Y,NA
"RTN","XLFNSLK",112,0)
 S Y="",IX=IX+$$NAME(IX,.Y,1),XL(NSP_"NAME")=Y,NA=Y
"RTN","XLFNSLK",113,0)
 S XL(NSP_"TYPE")=$$BN(RI(IX),RI(IX+1)),IX=IX+2
"RTN","XLFNSLK",114,0)
 S XL(NSP_"CLASS")=$$BN(RI(IX),RI(IX+1)),IX=IX+2
"RTN","XLFNSLK",115,0)
 S Y=RI(IX)*256+RI(IX+1),Y=Y*256+RI(IX+2),Y=Y*256+RI(IX+3)
"RTN","XLFNSLK",116,0)
 S XL(NSP_"TTL")=Y,IX=IX+4
"RTN","XLFNSLK",117,0)
 S (X,XL(NSP_"LENGTH"))=$$BN(RI(IX),RI(IX+1)),IX=IX+2 Q:X=0
"RTN","XLFNSLK",118,0)
 I XL(NSP_"TYPE")=1 D                                                                       ; IPv4 address
"RTN","XLFNSLK",119,0)
 . S XL(NSP_"DATA")=RI(IX)_"."_RI(IX+1)_"."_RI(IX+2)_"."_RI(IX+3),XL("B",NA)=XL(NSP_"DATA")
"RTN","XLFNSLK",120,0)
 I XL(NSP_"TYPE")=28 D                                                                      ; IPv6 address
"RTN","XLFNSLK",121,0)
 . S XL(NSP_"DATA")=$$H1(RI(IX))_$$H1(RI(IX+1))_":"_$$H1(RI(IX+2))_$$H1(RI(IX+3))_":"
"RTN","XLFNSLK",122,0)
 . S 
XL(NSP_"DATA")=XL(NSP_"DATA")_$$H1(RI(IX+4))_$$H1(RI(IX+5))_":"_$$H1(RI(IX+6))_$$H1(RI(IX+7))_":
"
"RTN","XLFNSLK",123,0)
 . S 
XL(NSP_"DATA")=XL(NSP_"DATA")_$$H1(RI(IX+8))_$$H1(RI(IX+9))_":"_$$H1(RI(IX+10))_$$H1(RI(IX+11))
_":"
"RTN","XLFNSLK",124,0)
 . S 
XL(NSP_"DATA")=XL(NSP_"DATA")_$$H1(RI(IX+12))_$$H1(RI(IX+13))_":"_$$H1(RI(IX+14))_$$H1(RI(IX+1
5))
"RTN","XLFNSLK",125,0)
 . S XL("B",NA)=XL(NSP_"DATA")
"RTN","XLFNSLK",126,0)
 I XL(NSP_"TYPE")=15 D MX(IX)                                                               ; MX entry
"RTN","XLFNSLK",127,0)
 S IX=IX+XL(NSP_"LENGTH")
"RTN","XLFNSLK",128,0)
 Q
"RTN","XLFNSLK",129,0)
NAME(I,NM,F) ;Decode a NAME section
"RTN","XLFNSLK",130,0)
 ;ZEXCEPT: RI ;Global variable within this routine
"RTN","XLFNSLK",131,0)
 N P,T,Y,X S NM=$G(NM) S:F T=0
"RTN","XLFNSLK",132,0)
 F  S X=RI(I) S:(X=0)&F T=T+1 Q:X=0  D  Q:X=0  ;Use X as flag to escape recursion.
"RTN","XLFNSLK",133,0)
 . I (X\64)=3 S X=$$NAME((X#64)*256+RI(I+1)+1,.NM,0),X=0 S:F T=T+2 Q
"RTN","XLFNSLK",134,0)
 . S NM=NM_$$PART(I+1,X),I=I+X+1 S:F T=T+X+1
"RTN","XLFNSLK",135,0)
 Q $G(T)
"RTN","XLFNSLK",136,0)
 ;
"RTN","XLFNSLK",137,0)
MX(IX) ;Hide IX changes
"RTN","XLFNSLK",138,0)
 ;ZEXCEPT: NSP,RI,XL ;Global variables within this routine
"RTN","XLFNSLK",139,0)
 N Y S Y=$$BN(RI(IX),RI(IX+1))
"RTN","XLFNSLK",140,0)
 F  Q:'$D(XL("P",Y))  S Y=Y+1
"RTN","XLFNSLK",141,0)
 S XL(NSP_"PREF")=Y,IX=IX+2
"RTN","XLFNSLK",142,0)
 S Y="",IX=IX+$$NAME(IX,.Y,1),XL(NSP_"NAME")=Y,XL("P",XL(NSP_"PREF"))=Y
"RTN","XLFNSLK",143,0)
 Q
"RTN","XLFNSLK",144,0)
 ;
"RTN","XLFNSLK",145,0)
BN(Z1,Z2) ;Convert two binary char 16 bit number into ASCII number
"RTN","XLFNSLK",146,0)
 Q Z1*256+Z2
"RTN","XLFNSLK",147,0)
 ;
"RTN","XLFNSLK",148,0)
WBN(Z1) ;Convert two byte string to a ASCII number
"RTN","XLFNSLK",149,0)
 Q $A(Z1,1)*256+$A(Z1,2)
"RTN","XLFNSLK",150,0)
 ;
"RTN","XLFNSLK",151,0)
H2(Z2) ;Convert 2 byte string to HEX
"RTN","XLFNSLK",152,0)
 N B S B=$A(Z2,1)*256+$A(Z2,2)
"RTN","XLFNSLK",153,0)
 Q $$H(B)
"RTN","XLFNSLK",154,0)
 ;
"RTN","XLFNSLK",155,0)
H1(Z1) ;Convert decimal number <= 256 to two digit HEX number
"RTN","XLFNSLK",156,0)
 N Y S Y=$$CNV^XLFUTL(Z1,16)
"RTN","XLFNSLK",157,0)
 Q $$RJ^XLFSTR(Y,2,"0")
"RTN","XLFNSLK",158,0)
 ;
"RTN","XLFNSLK",159,0)
H(Z1) Q $$BASE^XLFUTL(Z1,10,16)
"RTN","XLFNSLK",160,0)
 ;
"RTN","XLFNSLK",161,0)
BIN16(S) ;Convert two byte string to 16 bit binary
"RTN","XLFNSLK",162,0)
 N K,Y S S=$A(S,1)*256+$A(S,2),Y=""
"RTN","XLFNSLK",163,0)
 F K=0:1:15 S Y=(S\(2**K)#2)_Y
"RTN","XLFNSLK",164,0)
 Q Y
"RTN","XLFNSLK",165,0)
 ;
"RTN","XLFNSLK",166,0)
PART(S,L) ;
"RTN","XLFNSLK",167,0)
 ;ZEXCEPT: RI ;Global variable within this routine
"RTN","XLFNSLK",168,0)
 N R,A S R="" F A=S:1:S+L-1 S R=R_$C(RI(A))
"RTN","XLFNSLK",169,0)
 Q R_"."
"RTN","XLFNSLK",170,0)
 ;
"RTN","XLFNSLK",171,0)
TYPECODE(T) ;
"RTN","XLFNSLK",172,0)
 ;1=A:IPv4 address,2=NS:nameserver,5=CNAME,15=MX:mail exchange,28=AAAA:IPv6 address
"RTN","XLFNSLK",173,0)
 I +T Q $S(T=1:"A",T=2:"NS",T=5:"CNAME",T=15:"MX",T=28:"AAAA",1:"ZZ")
"RTN","XLFNSLK",174,0)
 Q $S(T="A":1,T="NS":2,T="CNAME":5,T="MX":15,T="AAAA":28,1:1)
"RTN","XLFNSLK",175,0)
 ;
"RTN","XLFNSLK",176,0)
CLASS(T) ;
"RTN","XLFNSLK",177,0)
 Q $S(T=1:"IN",1:"ZZ")
"RTN","XLFNSLK",178,0)
 ;
"RTN","XLFNSLK",179,0)
GETDNS(I) ;Get the address of our DNS
"RTN","XLFNSLK",180,0)
 N L S L=$G(^XTV(8989.3,1,"DNS"))
"RTN","XLFNSLK",181,0)
 Q $P(L,",",I)
"RTN","XLFNSLK",182,0)
 ;
"RTN","XLFNSLK",183,0)
SW(T,H,V) ;
"RTN","XLFNSLK",184,0)
 W ?T,$J(H,8),V
"RTN","XLFNSLK",185,0)
 Q
"RTN","XLFNSLK",186,0)
SAVEDEV ;Save calling device
"RTN","XLFNSLK",187,0)
 D:'$D(IO(0)) HOME^%ZIS D SAVDEV^%ZISUTL("XLFNSLK")
"RTN","XLFNSLK",188,0)
 Q
"RTN","XLFNSLK",189,0)
RESDEV ;Restore calling device
"RTN","XLFNSLK",190,0)
 D USE^%ZISUTL("XLFNSLK"),RMDEV^%ZISUTL("XLFNSLK")
"RTN","XLFNSLK",191,0)
 K IO("CLOSE")
"RTN","XLFNSLK",192,0)
 Q
"RTN","XLFNSLK",193,0)
LOG(M,XLFLOG) ;Log Debug messages
"RTN","XLFNSLK",194,0)
 ;ZEXCEPT: XLFLOG ;Global variable within this routine
"RTN","XLFNSLK",195,0)
 S XLFLOG=$G(XLFLOG)+1,XLFLOG(XLFLOG)=M
"RTN","XLFNSLK",196,0)
 Q
"RTN","XLFNSLK",197,0)
 ;
"RTN","XU8PS655")
1^17^^B102640640
"RTN","XU8PS659")
0^^B63050406^n/a
"RTN","XU8PS659",1,0)
XU8PS659 ;ISD/HGW - Post-Install for XU*8*659 ;12/17/15  10:49
"RTN","XU8PS659",2,0)
 ;;8.0;KERNEL;**659**;Jul 10, 1995;Build 22
"RTN","XU8PS659",3,0)
 ;Per VA Directive 6402, this routine should not be modified.
"RTN","XU8PS659",4,0)
 ;
"RTN","XU8PS659",5,0)
 ;  Post Installation Routine for patch XU*8.0*659
"RTN","XU8PS659",6,0)
 ;  EXTERNAL REFERENCES
"RTN","XU8PS659",7,0)
 ;    BMES^XPDUTL 10141
"RTN","XU8PS659",8,0)
 ;    $$FIND1^DIC
"RTN","XU8PS659",9,0)
 ;    UPDATE^DIE 2053
"RTN","XU8PS659",10,0)
 ;
"RTN","XU8PS659",11,0)
MAIN ; Control subroutine
"RTN","XU8PS659",12,0)
 N I,XDIR,XREF,XU8DATA,XU8ERRX,Y
"RTN","XU8PS659",13,0)
 ;
"RTN","XU8PS659",14,0)
 ; Delete old BSE Example entries from REMOTE APPLICATION file (#8994.5)
"RTN","XU8PS659",15,0)
 S XU8DATA(1)="XUSBSE TEST1" ; Name
"RTN","XU8PS659",16,0)
 S XU8ERRX=$$DELETE(.XU8DATA) ; Delete existing REMOTE APPLICATION entry
"RTN","XU8PS659",17,0)
 S XU8DATA(1)="XUSBSE TEST2" ; Name
"RTN","XU8PS659",18,0)
 S XU8ERRX=$$DELETE(.XU8DATA) ; Delete existing REMOTE APPLICATION entry
"RTN","XU8PS659",19,0)
 S XU8DATA(1)="XUSBSE TEST3" ; Name
"RTN","XU8PS659",20,0)
 S XU8ERRX=$$DELETE(.XU8DATA) ; Delete existing REMOTE APPLICATION entry
"RTN","XU8PS659",21,0)
 ;
"RTN","XU8PS659",22,0)
 ; Install IAM Provisioning entry into the REMOTE APPLICATION file (#8994.5)
"RTN","XU8PS659",23,0)
 S XU8DATA(1)="IAM PROVISIONING" ; Name
"RTN","XU8PS659",24,0)
 S XU8DATA(2)="XUS IAM USER PROVISIONING" ; ContextOption Name
"RTN","XU8PS659",25,0)
 S XU8DATA(3)="IAM User Provisioning" ; ContextOption Menu Text
"RTN","XU8PS659",26,0)
 S XU8DATA(4)="put butter square hat" ; Security phrase
"RTN","XU8PS659",27,0)
 ; For TYPE multiple, each entry should be 
XU8DATA(n)=CallBackType^CallBackPort^CallBackServer^URLString
"RTN","XU8PS659",28,0)
 ; where n is 5, 6, 7, 8 etc.
"RTN","XU8PS659",29,0)
 S XU8DATA(5)="S^-1^N/A^N/A"
"RTN","XU8PS659",30,0)
 S XU8ERRX=$$OPTION(.XU8DATA) ; Create CONTEXTOPTION if doesn't exist
"RTN","XU8PS659",31,0)
 D BMES^XPDUTL(XU8ERRX) ; XU8ERRX is "Success message" or "Error text"
"RTN","XU8PS659",32,0)
 S XU8ERRX=$$DELETE(.XU8DATA) ; Delete existing REMOTE APPLICATION entry
"RTN","XU8PS659",33,0)
 S XU8ERRX=$$CREATE(.XU8DATA) ; Create REMOTE APPLICATION entry
"RTN","XU8PS659",34,0)
 D BMES^XPDUTL(XU8ERRX) ; XU8ERRX is "Success message" or "Error text"
"RTN","XU8PS659",35,0)
 ;
"RTN","XU8PS659",36,0)
 ; Install IAM Binding entry into the REMOTE APPLICATION file (#8994.5)
"RTN","XU8PS659",37,0)
 S XU8DATA(1)="IAM BINDING" ; Name
"RTN","XU8PS659",38,0)
 S XU8DATA(2)="XUS IAM USER BINDING" ; ContextOption Name
"RTN","XU8PS659",39,0)
 S XU8DATA(3)="IAM User Binding App" ; ContextOption Menu Text
"RTN","XU8PS659",40,0)
 S XU8DATA(4)="de$lAyING55AMO)BAe29" ; Security phrase
"RTN","XU8PS659",41,0)
 ; For TYPE multiple, each entry should be 
XU8DATA(n)=CallBackType^CallBackPort^CallBackServer^URLString
"RTN","XU8PS659",42,0)
 ; where n is 5, 6, 7, 8 etc.
"RTN","XU8PS659",43,0)
 S XU8DATA(5)="S^-1^N/A^N/A"
"RTN","XU8PS659",44,0)
 S XU8ERRX=$$OPTION(.XU8DATA) ; Create CONTEXTOPTION if doesn't exist
"RTN","XU8PS659",45,0)
 D BMES^XPDUTL(XU8ERRX) ; XU8ERRX is "Success message" or "Error text"
"RTN","XU8PS659",46,0)
 S XU8ERRX=$$DELETE(.XU8DATA) ; Delete existing REMOTE APPLICATION entry
"RTN","XU8PS659",47,0)
 S XU8ERRX=$$CREATE(.XU8DATA) ; Create REMOTE APPLICATION entry
"RTN","XU8PS659",48,0)
 D BMES^XPDUTL(XU8ERRX) ; XU8ERRX is "Success message" or "Error text"
"RTN","XU8PS659",49,0)
 ;
"RTN","XU8PS659",50,0)
 ; Install NUMI entry into the REMOTE APPLICATION file (#8994.5)
"RTN","XU8PS659",51,0)
 S XU8DATA(1)="NUMI" ; Name
"RTN","XU8PS659",52,0)
 S XU8DATA(2)="WEBN NATL UTIL MGMT INTEG" ; ContextOption Name
"RTN","XU8PS659",53,0)
 S XU8DATA(3)="National Utilization Mgmt Integration" ; ContextOption Menu Text
"RTN","XU8PS659",54,0)
 S XU8DATA(4)="WEBN NATL UTIL MGMT INTEG" ; Security phrase
"RTN","XU8PS659",55,0)
 ; For TYPE multiple, each entry should be 
XU8DATA(n)=CallBackType^CallBackPort^CallBackServer^URLString
"RTN","XU8PS659",56,0)
 ; where n is 5, 6, 7, 8 etc.
"RTN","XU8PS659",57,0)
 S XU8DATA(5)="S^-1^N/A^N/A"
"RTN","XU8PS659",58,0)
 S XU8ERRX=$$OPTION(.XU8DATA) ; Create CONTEXTOPTION if doesn't exist
"RTN","XU8PS659",59,0)
 D BMES^XPDUTL(XU8ERRX) ; XU8ERRX is "Success message" or "Error text"
"RTN","XU8PS659",60,0)
 S XU8ERRX=$$DELETE(.XU8DATA) ; Delete existing REMOTE APPLICATION entry
"RTN","XU8PS659",61,0)
 S XU8ERRX=$$CREATE(.XU8DATA) ; Create REMOTE APPLICATION entry
"RTN","XU8PS659",62,0)
 D BMES^XPDUTL(XU8ERRX) ; XU8ERRX is "Success message" or "Error text"
"RTN","XU8PS659",63,0)
 ;
"RTN","XU8PS659",64,0)
 ; Install BMS entry into the REMOTE APPLICATION file (#8994.5)
"RTN","XU8PS659",65,0)
 S XU8DATA(1)="BMS" ; Name
"RTN","XU8PS659",66,0)
 S XU8DATA(2)="WEBB BED MGMT SOLUTION" ; ContextOption Name
"RTN","XU8PS659",67,0)
 S XU8DATA(3)="Bed Management Solution" ; ContextOption Menu Text
"RTN","XU8PS659",68,0)
 S XU8DATA(4)="WEBB BED MGMT SOLUTION" ; Security phrase
"RTN","XU8PS659",69,0)
 ; For TYPE multiple, each entry should be 
XU8DATA(n)=CallBackType^CallBackPort^CallBackServer^URLString
"RTN","XU8PS659",70,0)
 ; where n is 5, 6, 7, 8 etc.
"RTN","XU8PS659",71,0)
 S XU8DATA(5)="S^-1^N/A^N/A"
"RTN","XU8PS659",72,0)
 S XU8ERRX=$$OPTION(.XU8DATA) ; Create CONTEXTOPTION if doesn't exist
"RTN","XU8PS659",73,0)
 D BMES^XPDUTL(XU8ERRX) ; XU8ERRX is "Success message" or "Error text"
"RTN","XU8PS659",74,0)
 S XU8ERRX=$$DELETE(.XU8DATA) ; Delete existing REMOTE APPLICATION entry
"RTN","XU8PS659",75,0)
 S XU8ERRX=$$CREATE(.XU8DATA) ; Create REMOTE APPLICATION entry
"RTN","XU8PS659",76,0)
 D BMES^XPDUTL(XU8ERRX) ; XU8ERRX is "Success message" or "Error text"
"RTN","XU8PS659",77,0)
 ;
"RTN","XU8PS659",78,0)
 ;  Install entry into the DIALOG file (#.84)
"RTN","XU8PS659",79,0)
 ;NUMBER: 30810.63                        DIALOG NUMBER: 30810.63
"RTN","XU8PS659",80,0)
 ;  TYPE: GENERAL MESSAGE                 PACKAGE: KERNEL
"RTN","XU8PS659",81,0)
 ;  SHORT DESCRIPTION: STS token not valid.
"RTN","XU8PS659",82,0)
 ; TEXT:
"RTN","XU8PS659",83,0)
 ;  Unable to sign on using Identity and Access Management STS token.
"RTN","XU8PS659",84,0)
 K XU8DATA,XU8ERRX
"RTN","XU8PS659",85,0)
 S XU8DATA(1)=30810.63
"RTN","XU8PS659",86,0)
 S XU8DATA(2)="KERNEL"
"RTN","XU8PS659",87,0)
 S XU8DATA(3)=2 ;"GENERAL MESSAGE"
"RTN","XU8PS659",88,0)
 S XU8DATA(4)="STS token not valid."
"RTN","XU8PS659",89,0)
 S XU8DATA(5)="Unable to sign on using Identity and Access Management STS token. Try using 
Access/Verify codes."
"RTN","XU8PS659",90,0)
 S XU8ERRX=$$NEWDIA(.XU8DATA)
"RTN","XU8PS659",91,0)
 D BMES^XPDUTL(XU8ERRX) ; XU8ERRX is "Success message" or "Error text"
"RTN","XU8PS659",92,0)
 ;
"RTN","XU8PS659",93,0)
 ;  Install entries into KERNEL SYSTEMS PARAMETERS file (#8989.3)
"RTN","XU8PS659",94,0)
 K XU8DATA,XU8ERRX
"RTN","XU8PS659",95,0)
 S XU8DATA(1)="eauth.DNS   "
"RTN","XU8PS659",96,0)
 S XU8DATA(2)="Department Of Veterans Affairs"
"RTN","XU8PS659",97,0)
 S XU8DATA(3)="urn:oid:2.16.840.1.113883.4.349"
"RTN","XU8PS659",98,0)
 S XU8ERRX=$$NEWKSP(.XU8DATA)
"RTN","XU8PS659",99,0)
 D BMES^XPDUTL(XU8ERRX) ; XU8ERRX is "Success message" or "Error text"
"RTN","XU8PS659",100,0)
 ;
"RTN","XU8PS659",101,0)
 K ^XU8P655("VACAA") ;Cleanup after patch XU*8*655
"RTN","XU8PS659",102,0)
 ;
"RTN","XU8PS659",103,0)
 Q
"RTN","XU8PS659",104,0)
 ;
"RTN","XU8PS659",105,0)
OPTION(XU8DATA) ; Create CONTEXTOPTION if doesn't exist
"RTN","XU8PS659",106,0)
 N XU8ERR,XU8FDA,XU8IEN,XU8MSG
"RTN","XU8PS659",107,0)
 S XU8IEN=$$FIND1^DIC(19,"","X",XU8DATA(2),"B")
"RTN","XU8PS659",108,0)
 S XU8ERR="Error message: "_XU8IEN
"RTN","XU8PS659",109,0)
 I +XU8IEN>0 S XU8ERR="OPTION exists at IEN = "_XU8IEN
"RTN","XU8PS659",110,0)
 I +XU8IEN=0 S XU8ERR="OPTION "_XU8DATA(2)_" created" D
"RTN","XU8PS659",111,0)
 . S XU8FDA(19,"?+1,",.01)=XU8DATA(2)
"RTN","XU8PS659",112,0)
 . S XU8FDA(19,"?+1,",1)=XU8DATA(3)
"RTN","XU8PS659",113,0)
 . S XU8FDA(19,"?+1,",4)="B" ; B:Broker (Client/Server)
"RTN","XU8PS659",114,0)
 . D UPDATE^DIE("","XU8FDA","XU8IEN","XU8MSG")
"RTN","XU8PS659",115,0)
 . I $D(XU8MSG) S XU8ERR="   **ERROR** "_$G(XU8MSG("DIERR",1))_" Unable to create OPTION entry 
"_XU8DATA(2)
"RTN","XU8PS659",116,0)
 D CLEAN^DILF
"RTN","XU8PS659",117,0)
 Q XU8ERR
"RTN","XU8PS659",118,0)
 ;
"RTN","XU8PS659",119,0)
DELETE(XU8DATA) ; Delete existing REMOTE APPLICATION entry
"RTN","XU8PS659",120,0)
 N DA,DIK,XU8IEN
"RTN","XU8PS659",121,0)
 S XU8IEN=$$FIND1^DIC(8994.5,"","X",XU8DATA(1),"B")
"RTN","XU8PS659",122,0)
 I $G(XU8IEN)>0 D
"RTN","XU8PS659",123,0)
 . S DIK="^XWB(8994.5,",DA=XU8IEN
"RTN","XU8PS659",124,0)
 . D ^DIK
"RTN","XU8PS659",125,0)
 . K XU8IEN
"RTN","XU8PS659",126,0)
 Q 1
"RTN","XU8PS659",127,0)
CREATE(XU8DATA) ; Create new REMOTE APPLICATION entry
"RTN","XU8PS659",128,0)
 N XU8ERR,XU8FDA,XU8I,XU8IEN,XU8IENS,XU8MSG
"RTN","XU8PS659",129,0)
 S XU8ERR="   REMOTE APPLICATION entry created: "_XU8DATA(1)
"RTN","XU8PS659",130,0)
 S XU8FDA(8994.5,"?+1,",.01)=XU8DATA(1) ; NAME
"RTN","XU8PS659",131,0)
 S XU8FDA(8994.5,"?+1,",.02)=$$FIND1^DIC(19,"","X",XU8DATA(2),"B") ; CONTEXTOPTION
"RTN","XU8PS659",132,0)
 S XU8FDA(8994.5,"?+1,",.03)=$$SHAHASH^XUSHSH(256,XU8DATA(4),"B") ; APPLICATIONCODE
"RTN","XU8PS659",133,0)
 D UPDATE^DIE("","XU8FDA","XU8IEN","XU8MSG")
"RTN","XU8PS659",134,0)
 I $D(XU8MSG) D
"RTN","XU8PS659",135,0)
 . S XU8ERR="   **ERROR** "_$G(XU8MSG("DIERR",1))_" Unable to create REMOTE APPLICATION: 
"_XU8DATA(1)
"RTN","XU8PS659",136,0)
 ; Find the REMOTE APPLICATION
"RTN","XU8PS659",137,0)
 S XU8IENS=$$FIND1^DIC(8994.5,"","X",XU8DATA(1),"B")
"RTN","XU8PS659",138,0)
 I +XU8IENS<1 S XU8ERR=XU8IENS Q XU8ERR
"RTN","XU8PS659",139,0)
 ; Fill in CALLBACKTYPE multiple
"RTN","XU8PS659",140,0)
 S XU8I=4 F  S XU8I=$O(XU8DATA(XU8I)) Q:XU8I=""  D
"RTN","XU8PS659",141,0)
 . N XU8FDA,XU8IEN,XU8MSG,XU8TEST,XU8J,XU8FLAG
"RTN","XU8PS659",142,0)
 . ; Check for duplicates (loop through CALLBACKTYPE for this entry)
"RTN","XU8PS659",143,0)
 . S XU8J=0 F  S XU8J=$O(^XWB(8994.5,XU8IENS,1,"B",$E(XU8DATA(XU8I),1,1),XU8J)) 
Q:(XU8J="")!($D(XU8FLAG))  D
"RTN","XU8PS659",144,0)
 . . I $G(XU8DATA(XU8I))=$G(^XWB(8994.5,XU8IENS,1,XU8J,0)) S XU8FLAG=1
"RTN","XU8PS659",145,0)
 . I '$D(XU8FLAG) D
"RTN","XU8PS659",146,0)
 . . S XU8FDA(8994.51,"+2,"_XU8IENS_",",.01)=$P(XU8DATA(XU8I),"^",1) ; CALLBACKTYPE
"RTN","XU8PS659",147,0)
 . . S XU8FDA(8994.51,"+2,"_XU8IENS_",",.02)=$P(XU8DATA(XU8I),"^",2) ; CALLBACKPORT
"RTN","XU8PS659",148,0)
 . . S XU8FDA(8994.51,"+2,"_XU8IENS_",",.03)=$P(XU8DATA(XU8I),"^",3) ; CALLBACKSERVER
"RTN","XU8PS659",149,0)
 . . S XU8FDA(8994.51,"+2,"_XU8IENS_",",.04)=$P(XU8DATA(XU8I),"^",4) ; URLSTRING
"RTN","XU8PS659",150,0)
 . . D UPDATE^DIE("","XU8FDA","XU8IEN","XU8MSG")
"RTN","XU8PS659",151,0)
 . . I $D(XU8MSG) D
"RTN","XU8PS659",152,0)
 . . . S XU8ERR="   **ERROR** "_$G(XU8MSG("DIERR",1))_" Unable to update REMOTE APPLICATION: 
"_XU8DATA(1)
"RTN","XU8PS659",153,0)
 ;
"RTN","XU8PS659",154,0)
 D CLEAN^DILF
"RTN","XU8PS659",155,0)
 Q XU8ERR
"RTN","XU8PS659",156,0)
 ;
"RTN","XU8PS659",157,0)
NEWDIA(XU8DATA) ; Create DIALOG entry
"RTN","XU8PS659",158,0)
 N DA,DIK,XU8DT,XU8ERR,XU8FDA,XU8IEN,XU8MSG
"RTN","XU8PS659",159,0)
 ; Delete existing entry if it exists, before creating updated entry
"RTN","XU8PS659",160,0)
 S XU8IEN=$$FIND1^DIC(.84,"","X",XU8DATA(1),"B")
"RTN","XU8PS659",161,0)
 I $G(XU8IEN)>0 D
"RTN","XU8PS659",162,0)
 . S DIK="^DI(.84,",DA=XU8IEN
"RTN","XU8PS659",163,0)
 . D ^DIK
"RTN","XU8PS659",164,0)
 . K XU8IEN
"RTN","XU8PS659",165,0)
 S XU8ERR="   DIALOG entry created: "_XU8DATA(4)
"RTN","XU8PS659",166,0)
 S XU8IEN(1)=XU8DATA(1)
"RTN","XU8PS659",167,0)
 S XU8FDA(.84,"+1,",.01)=XU8DATA(1) ;IEN
"RTN","XU8PS659",168,0)
 S XU8FDA(.84,"+1,",1)=XU8DATA(3) ;TYPE
"RTN","XU8PS659",169,0)
 S XU8FDA(.84,"+1,",1.2)=XU8DATA(2) ;PACKAGE
"RTN","XU8PS659",170,0)
 S XU8FDA(.84,"+1,",1.3)=XU8DATA(4) ;SHORT DESCRIPTION
"RTN","XU8PS659",171,0)
 D UPDATE^DIE("","XU8FDA","XU8IEN","XU8MSG")
"RTN","XU8PS659",172,0)
 I $D(XU8MSG) S XU8ERR="   **ERROR** "_$G(XU8MSG("DIERR",1))_" Unable to create DIALOG entry: 
"_XU8DATA(4) D CLEAN^DILF Q XU8ERR
"RTN","XU8PS659",173,0)
 S XU8IEN=$$FIND1^DIC(.84,"","X",XU8DATA(1),"B")
"RTN","XU8PS659",174,0)
 I $G(XU8IEN)>0 D
"RTN","XU8PS659",175,0)
 . S XU8DT(1)=XU8DATA(5) ;TEXT
"RTN","XU8PS659",176,0)
 . D WP^DIE(.84,XU8IEN_",",4,,"XU8DT","XU8MSG")
"RTN","XU8PS659",177,0)
 I $D(XU8MSG) D
"RTN","XU8PS659",178,0)
 . S XU8ERR="   **ERROR** "_$G(XU8MSG("DIERR",1))_" Unable to create DIALOG entry: "_XU8DATA(4)
"RTN","XU8PS659",179,0)
 . S DIK="^DI(.84,",DA=XU8IEN
"RTN","XU8PS659",180,0)
 . D ^DIK
"RTN","XU8PS659",181,0)
 . K XU8IEN
"RTN","XU8PS659",182,0)
 D CLEAN^DILF
"RTN","XU8PS659",183,0)
 Q XU8ERR
"RTN","XU8PS659",184,0)
 ;
"RTN","XU8PS659",185,0)
NEWKSP(XU8DATA) ; Create KERNEL SYSTEM PARAMETERS entries
"RTN","XU8PS659",186,0)
 N DA,DIK,XU8ERR,XU8FDA,XU8MSG
"RTN","XU8PS659",187,0)
 S XU8ERR="   KERNEL SYSTEM PARAMETERS fields populated: SECURITY TOKEN SERVICE, 
ORGANIZATION, ORGANIZATION ID"
"RTN","XU8PS659",188,0)
 S XU8FDA(8989.3,"1,",200.1)=XU8DATA(1)
"RTN","XU8PS659",189,0)
 S XU8FDA(8989.3,"1,",200.2)=XU8DATA(2)
"RTN","XU8PS659",190,0)
 S XU8FDA(8989.3,"1,",200.3)=XU8DATA(3)
"RTN","XU8PS659",191,0)
 D FILE^DIE("E","XU8FDA","XU8MSG")
"RTN","XU8PS659",192,0)
 I $D(XU8MSG) D
"RTN","XU8PS659",193,0)
 . S XU8ERR="   **ERROR** "_$G(XU8MSG("DIERR",1))_" Unable to populate KERNEL SYSTEM 
PARAMETERS fields"
"RTN","XU8PS659",194,0)
 D CLEAN^DILF
"RTN","XU8PS659",195,0)
 Q XU8ERR
"RTN","XU8PS659",196,0)
 ;
"RTN","XUCERT")
0^18^B4132125^n/a
"RTN","XUCERT",1,0)
XUCERT ;ISD/HGW Kernel PKI Certificate Utilities ;10/01/15  14:19
"RTN","XUCERT",2,0)
 ;;8.0;KERNEL;**659**;Jul 10, 1995;Build 22
"RTN","XUCERT",3,0)
 ;Per VA Directive 6402, this routine should not be modified.
"RTN","XUCERT",4,0)
 ;
"RTN","XUCERT",5,0)
 Q
"RTN","XUCERT",6,0)
VALIDATE(DOC) ;Extrinsic Function.
"RTN","XUCERT",7,0)
 ;Validate the signatures in a digitally signed XML document which contains an EncryptedData element 
and EncryptedKey elements.
"RTN","XUCERT",8,0)
 ; Input:     DOC     = This string is either a closed reference to a global root containing the XML document 
or a filename
"RTN","XUCERT",9,0)
 ;                      and path reference identifying the XML document on the host system. See the Kernel 
Developers Guide
"RTN","XUCERT",10,0)
 ;                      documentation on $$EN^MXMLDOM() for detailed requirements for the format of the 
input global.
"RTN","XUCERT",11,0)
 ; Return:    Fail    = "-1^Error Message"
"RTN","XUCERT",12,0)
 ;            Success = 1
"RTN","XUCERT",13,0)
 ;
"RTN","XUCERT",14,0)
 ;ZEXCEPT: %New,%XML,Document,OpenFile,OpenStream,Reader,ValidateDocument,class ;ObjectScript
"RTN","XUCERT",15,0)
 N XUREAD,XUSIG,XUSTATUS,XUVER
"RTN","XUCERT",16,0)
 S XUREAD=$$READER^XUCERT1(DOC) ;Read XML document
"RTN","XUCERT",17,0)
 I $G(XUREAD)["-1^" Q XUREAD
"RTN","XUCERT",18,0)
 S XUSIG=$$SGNTR^XUCERT1(XUREAD) ;Find digital signature
"RTN","XUCERT",19,0)
 I $G(XUSIG)["-1^" Q XUSIG
"RTN","XUCERT",20,0)
 D GETISSUE(XUSIG) ;Save subject of X509 certificate (issuer of signature)
"RTN","XUCERT",21,0)
 S XUVER=$$VERSION^%ZOSV() S XUVER=$P(XUVER,".",1)_"."_$P(XUVER,".",2)
"RTN","XUCERT",22,0)
 I XUVER'<2015.2 D
"RTN","XUCERT",23,0)
 . S XUSTATUS=$$VAL1^XUCERT1(XUREAD,XUSIG)
"RTN","XUCERT",24,0)
 E  D
"RTN","XUCERT",25,0)
 . S XUSTATUS=$$VAL2^XUCERT1(XUREAD,XUSIG)
"RTN","XUCERT",26,0)
 Q XUSTATUS
"RTN","XUCERT",27,0)
 ;
"RTN","XUCERT",28,0)
GETISSUE(SIG) ;Subroutine. Save X509 Certificate owner to XOBDATA("XOB RPC","SAML",ISSUER")
"RTN","XUCERT",29,0)
 ;ZEXCEPT: Encryption,X509GetField,XOBDATA ;ObjectScript and environment variables
"RTN","XUCERT",30,0)
 N CERT
"RTN","XUCERT",31,0)
 S CERT=$$CERT^XUCERT1(SIG)
"RTN","XUCERT",32,0)
 I +CERT=-1 Q  ;Cannot get certificate
"RTN","XUCERT",33,0)
 S XOBDATA("XOB RPC","SAML","ISSUER")=$System.Encryption.X509GetField(CERT,"Subject")
"RTN","XUCERT",34,0)
 Q
"RTN","XUCERT",35,0)
 ;
"RTN","XUCERT",36,0)
TEST ;Subroutine. System checks to help with troubleshooting.
"RTN","XUCERT",37,0)
 ;Check if Cache version >= 2015.2
"RTN","XUCERT",38,0)
 ;    12345678901234567890123456789012345678901234567890123456789012345678901234567890
"RTN","XUCERT",39,0)
 W !,"XML digital signature validation is done differently depending on the version"
"RTN","XUCERT",40,0)
 W !,"of Cache being used on your system:"
"RTN","XUCERT",41,0)
 W !,"   Versions greater than or equal to 2015.2 use $$VAL1^XUCERT1"
"RTN","XUCERT",42,0)
 W !,"   Versions less than 2015.2 use $$VAL2^XUCERT1"
"RTN","XUCERT",43,0)
 W !,"   Your Cache Version is ",$$VERSION^%ZOSV(),!
"RTN","XUCERT",44,0)
 ;
"RTN","XUCERT",45,0)
 ;Check if PKI chain of trust to root is available (how?)
"RTN","XUCERT",46,0)
 ; ** Apparently Cache uses OpenSSL on underlying server for chain of trust. Check OpenSSL version?
"RTN","XUCERT",47,0)
 ;Check if %SuperServer and %TELNET/SSL is available (how? with https?)
"RTN","XUCERT",48,0)
 ; ** Is this still needed?
"RTN","XUCERT",49,0)
 ;Check if a local X.509 certificate is installed (how? same as %SuperServer check?)
"RTN","XUCERT",50,0)
 ; ** Not needed. All sites use SSL, so they have a certificate on the server.
"RTN","XUCERT",51,0)
 Q
"RTN","XUCERT",52,0)
 ;
"RTN","XUCERT1")
0^22^B20606802^n/a
"RTN","XUCERT1",1,0)
XUCERT1 ;ISD/HGW Kernel PKI Certificate Utilities (cont) ;09/28/15  09:08
"RTN","XUCERT1",2,0)
 ;;8.0;KERNEL;**659**;Jul 10, 1995;Build 22
"RTN","XUCERT1",3,0)
 ;Per VA Directive 6402, this routine should not be modified.
"RTN","XUCERT1",4,0)
 ;
"RTN","XUCERT1",5,0)
 Q
"RTN","XUCERT1",6,0)
VAL1(DOC,SIG) ;Function. Validate Document (Cache 2015.2 or greater)
"RTN","XUCERT1",7,0)
 ;ZEXCEPT: Document,ValidateDocument ;Object Script
"RTN","XUCERT1",8,0)
 N XUDOC,XUSTATUS
"RTN","XUCERT1",9,0)
 S XUDOC=DOC.Document ;Create the OREF
"RTN","XUCERT1",10,0)
 I $G(XUDOC)="" Q "-1^Failed to import XML document"
"RTN","XUCERT1",11,0)
 S XUSTATUS=SIG.ValidateDocument(XUDOC)
"RTN","XUCERT1",12,0)
 I $G(XUSTATUS)["Failed" Q "-1^Failed data integrity or signature validation check"
"RTN","XUCERT1",13,0)
 Q 1
"RTN","XUCERT1",14,0)
 ;
"RTN","XUCERT1",15,0)
VAL2(DOC,SIG) ;Function. Validate Document (Less than Cache 2015.2)
"RTN","XUCERT1",16,0)
 N XUSTATUS
"RTN","XUCERT1",17,0)
 S XUSTATUS=$$CHKDATA(DOC,SIG)  ; check integrity
"RTN","XUCERT1",18,0)
 I 'XUSTATUS Q "-1^Failed data integrity check"
"RTN","XUCERT1",19,0)
 S XUSTATUS=$$CHKSIGN(DOC,SIG)  ; check signature is valid
"RTN","XUCERT1",20,0)
 I 'XUSTATUS Q "-1^Failed signature validation"
"RTN","XUCERT1",21,0)
 Q 1
"RTN","XUCERT1",22,0)
 ;
"RTN","XUCERT1",23,0)
READER(DOC) ;Function. Reads XML Document
"RTN","XUCERT1",24,0)
 ;ZEXCEPT: %New,%XML,OpenFile,OpenStream,Reader,class ;Object Script
"RTN","XUCERT1",25,0)
 N XUIN,XUREAD,XUSC
"RTN","XUCERT1",26,0)
 S XUREAD=##class(%XML.Reader).%New() ;Create OREF instance in memory
"RTN","XUCERT1",27,0)
 I $E(DOC)="^" D
"RTN","XUCERT1",28,0)
 . S XUIN=$$LOADSTRM(DOC) ;Extract stream from global
"RTN","XUCERT1",29,0)
 . S XUSC=XUREAD.OpenStream(XUIN) ;Import from stream
"RTN","XUCERT1",30,0)
 E  D
"RTN","XUCERT1",31,0)
 . S XUSC=XUREAD.OpenFile(DOC) ;Import from file
"RTN","XUCERT1",32,0)
 I $G(XUSC)'=1 Q "-1^"_$G(XUSC)
"RTN","XUCERT1",33,0)
 Q XUREAD
"RTN","XUCERT1",34,0)
 ;
"RTN","XUCERT1",35,0)
SGNTR(READER) ;Function. Finds digital signature
"RTN","XUCERT1",36,0)
 N SIGNATURE,STATUS
"RTN","XUCERT1",37,0)
 D READER.Correlate("Signature","%XML.Security.Signature")
"RTN","XUCERT1",38,0)
 D READER.Next(.SIGNATURE,.STATUS)
"RTN","XUCERT1",39,0)
 I $G(SIGNATURE)="" Q "-1^Failed to find digital signature"
"RTN","XUCERT1",40,0)
 Q SIGNATURE
"RTN","XUCERT1",41,0)
 ;
"RTN","XUCERT1",42,0)
CHKDATA(READER,SIG) ;Function. Check integrity of signed data
"RTN","XUCERT1",43,0)
 ; by comparing computed digest with incoming digest value
"RTN","XUCERT1",44,0)
 N COMPUTED
"RTN","XUCERT1",45,0)
 S COMPUTED=$$DIGESTCP(READER,SIG)
"RTN","XUCERT1",46,0)
 Q COMPUTED=$$DIGEST(SIG)
"RTN","XUCERT1",47,0)
 ;
"RTN","XUCERT1",48,0)
DIGESTCP(READER,SIG) ;Function. Compute SHA digest value
"RTN","XUCERT1",49,0)
 ;ZEXCEPT: %New,%XML,ComputeSha1Digest,Document,GetNode,NodeId,Writer,class
"RTN","XUCERT1",50,0)
 N NODE,WRITER,BITLENGT,ISSTR,MIME,SIGNNODE,PREFIXL,CANONTXT
"RTN","XUCERT1",51,0)
 S NODE=READER.Document.GetNode("")
"RTN","XUCERT1",52,0)
 S NODE.NodeId=$$REFNODE(READER)
"RTN","XUCERT1",53,0)
 S SIGNNODE=SIG.NodeId
"RTN","XUCERT1",54,0)
 S WRITER=##class(%XML.Writer).%New()
"RTN","XUCERT1",55,0)
 S BITLENGT=160
"RTN","XUCERT1",56,0)
 S ISSTR=0
"RTN","XUCERT1",57,0)
 S MIME=""
"RTN","XUCERT1",58,0)
 Q SIG.ComputeSha1Digest(NODE,SIGNNODE,WRITER,.PREFIXL,BITLENGT,ISSTR,.CANONTXT,MIME)
"RTN","XUCERT1",59,0)
 ;
"RTN","XUCERT1",60,0)
REFNODE(READER) ;Function. Get reference node which is Assertion node since GetNodeById can't find 
"ID"
"RTN","XUCERT1",61,0)
 ;ZEXCEPT: NodeId,STATUS
"RTN","XUCERT1",62,0)
 N ASSERTION
"RTN","XUCERT1",63,0)
 D READER.Rewind()
"RTN","XUCERT1",64,0)
 D READER.Correlate("Assertion","%SAML.Assertion")
"RTN","XUCERT1",65,0)
 D READER.Next(.ASSERTION,.STATUS)
"RTN","XUCERT1",66,0)
 Q ASSERTION.NodeId
"RTN","XUCERT1",67,0)
 ;
"RTN","XUCERT1",68,0)
DIGEST(SIGNATURE) ;Function. Find incoming digest value
"RTN","XUCERT1",69,0)
 ;ZEXCEPT: DigestValue,GetAt,Reference,SignedInfo
"RTN","XUCERT1",70,0)
 N REF
"RTN","XUCERT1",71,0)
 S REF=SIGNATURE.SignedInfo.Reference.GetAt(1)
"RTN","XUCERT1",72,0)
 Q REF.DigestValue
"RTN","XUCERT1",73,0)
 ;
"RTN","XUCERT1",74,0)
CHKSIGN(READER,SIGNATURE) ;Function. Validate digital signature
"RTN","XUCERT1",75,0)
 ; Return value: 1 if the signature was successfully verified, 0 otherwise.
"RTN","XUCERT1",76,0)
 ;ZEXCEPT: 
%New,%XML,Canonicalize,Certificate,Document,Encryption,GetNode,GetXMLString,KeyInfo,NodeId,Out
putToString,RSASHAVerify,SignatureValue,SignedInfo,ValidateTokenRef,Writer,X509Credentials,class
"RTN","XUCERT1",77,0)
 N BITLENGT,CAFILE,CERT,CRLFILE,SIGNTXT,SIGNVAL,STATUS
"RTN","XUCERT1",78,0)
 S BITLENGT=256 ; (Integer) Length in bits of desired hash, where 256 is SHA-256
"RTN","XUCERT1",79,0)
 S SIGNTXT=$$SIGNTEXT(READER,SIGNATURE) ; (String) Data that was signed
"RTN","XUCERT1",80,0)
 S SIGNVAL=SIGNATURE.SignatureValue ; (String) Signature to be verified
"RTN","XUCERT1",81,0)
 S CERT=$$CERT(SIGNATURE) ; (String) X.509 certificate containing the RSA public key to validate the 
signature
"RTN","XUCERT1",82,0)
 I +CERT=-1 Q CERT
"RTN","XUCERT1",83,0)
 ;RSASHAVerify works with OpenSSL on Windows and Linux, but crashes with VMS.
"RTN","XUCERT1",84,0)
 I $$VERSION^%ZOSV(1)["OpenVMS" Q 1  ;Quit if VMS, skip signature validation
"RTN","XUCERT1",85,0)
 S STATUS=$System.Encryption.RSASHAVerify(BITLENGT,SIGNTXT,SIGNVAL,CERT)
"RTN","XUCERT1",86,0)
 Q STATUS=1
"RTN","XUCERT1",87,0)
 ;
"RTN","XUCERT1",88,0)
SIGNTEXT(READER,SIGNATURE) ;Function. Retrieves the SignedInfo text
"RTN","XUCERT1",89,0)
 ;ZEXCEPT: 
%New,%XML,Canonicalize,Document,GetNode,GetXMLString,NodeId,OutputToString,SignedInfo,Writer,
class ;ObjectScript
"RTN","XUCERT1",90,0)
 N NODE,PREFARR,WRITER,SC
"RTN","XUCERT1",91,0)
 S NODE=READER.Document.GetNode("")
"RTN","XUCERT1",92,0)
 S NODE.NodeId=SIGNATURE.SignedInfo.NodeId
"RTN","XUCERT1",93,0)
 S PREFARR="c14n" ; signing prefix array
"RTN","XUCERT1",94,0)
 S WRITER=##class(%XML.Writer).%New()
"RTN","XUCERT1",95,0)
 S SC=WRITER.OutputToString()
"RTN","XUCERT1",96,0)
 S SC=WRITER.Canonicalize(NODE,.PREFARR)
"RTN","XUCERT1",97,0)
 Q WRITER.GetXMLString(.SC) ; SignedInfo
"RTN","XUCERT1",98,0)
 ;
"RTN","XUCERT1",99,0)
CERT(SIG) ;Function. Retrieves a certificate
"RTN","XUCERT1",100,0)
 ;ZEXCEPT: Certificate,KeyInfo,ValidateTokenRef,X509Credentials ;ObjectScript
"RTN","XUCERT1",101,0)
 N KEYINFO,ERROR
"RTN","XUCERT1",102,0)
 S KEYINFO=SIG.KeyInfo
"RTN","XUCERT1",103,0)
 S ERROR=KEYINFO.ValidateTokenRef("")
"RTN","XUCERT1",104,0)
 I ERROR'="" Q "-1^Invalid KeyInfo"
"RTN","XUCERT1",105,0)
 Q KEYINFO.X509Credentials.Certificate
"RTN","XUCERT1",106,0)
 ;
"RTN","XUCERT1",107,0)
LOADSTRM(GLO) ;Intrinsic Function. Load global into stream
"RTN","XUCERT1",108,0)
 ;ZEXCEPT: %New,%Stream,GlobalCharacter,class ;ObjectScript
"RTN","XUCERT1",109,0)
 N GLOREF,I,X,XMLSTRM,XQ,Y
"RTN","XUCERT1",110,0)
 S Y=GLO
"RTN","XUCERT1",111,0)
 S XQ=$P(Y,")") ;or use $$OREF^DILF(closed_root) to convert closed root to open root?
"RTN","XUCERT1",112,0)
 S XMLSTRM=##class(%Stream.GlobalCharacter).%New() ;Create OREF instance in memory
"RTN","XUCERT1",113,0)
 ;Read XML from global, starting at the beginning, into XMLSTRM
"RTN","XUCERT1",114,0)
 F I=0:0 D  Q:Y'[XQ
"RTN","XUCERT1",115,0)
 . S Y=$Q(@Y) Q:Y'[XQ
"RTN","XUCERT1",116,0)
 . S X=$G(@Y)
"RTN","XUCERT1",117,0)
 . D XMLSTRM.Write(X)
"RTN","XUCERT1",118,0)
 Q XMLSTRM
"RTN","XUCERT1",119,0)
 ;
"RTN","XUESSO1")
0^11^B93859687^B77693554
"RTN","XUESSO1",1,0)
XUESSO1 ;SEA/LUKE Single Sign-on Utilities ;03/08/16  08:16
"RTN","XUESSO1",2,0)
 ;;8.0;KERNEL;**165,183,196,245,254,269,337,395,466,523,655,659**;Jul 10, 1995;Build 22
"RTN","XUESSO1",3,0)
 ;Per VA Directive 6402, this routine should not be modified.
"RTN","XUESSO1",4,0)
 ;
"RTN","XUESSO1",5,0)
GET(INDUZ) ;Gather identifying data from user's home site.
"RTN","XUESSO1",6,0)
 ;Called by SETVISIT^XUSBSE1 (Get visitor info for TOKEN)
"RTN","XUESSO1",7,0)
 ;Called by SNDQRY^DGROHLS (Retrieve user info) and SETUP^XWB2HL7 (Get visitor info)
"RTN","XUESSO1",8,0)
 ;Called by (unknown) (VSA/VistA.js)
"RTN","XUESSO1",9,0)
 ;To visit a remote site, user must have: Name, Access/Verify Codes, SSN (no pseudo), Station Name, Site 
Number
"RTN","XUESSO1",10,0)
 ;The following data is optional: Phone, SecID, Network Username
"RTN","XUESSO1",11,0)
 N %,NAME,SITE,SSN,PHONE,X,N,NETWORK
"RTN","XUESSO1",12,0)
 I '$D(DUZ) Q "-1^Insufficient info to allow visiting:  No DUZ"
"RTN","XUESSO1",13,0)
 I '$D(DUZ(2)) Q "-1^Insufficient info to allow visiting:  Missing DUZ(2)"
"RTN","XUESSO1",14,0)
 S N=$G(^VA(200,DUZ,0))
"RTN","XUESSO1",15,0)
 I '$L(N) Q "-1^Insufficient info to allow visiting:  Missing NPF Zero Node"
"RTN","XUESSO1",16,0)
 S %=$P(N,U,3) I $L(%)<1 Q "-1^Insufficient info to allow visiting:  No Access Code"
"RTN","XUESSO1",17,0)
 S %=$P($G(^VA(200,DUZ,.1)),U,2) I $L(%)<1 Q "-1^Insufficient info to allow visiting:  No Verify Code"
"RTN","XUESSO1",18,0)
 S %=$P(N,U,11) I $L(%)>1,(DT>%) Q "-1^Insufficient info to allow visiting:  Terminated User"
"RTN","XUESSO1",19,0)
 I $P($$ACTIVE^XUSER(DUZ),U,1)'=1 Q "-1^Insufficient info to allow visiting:  Not an active user"
"RTN","XUESSO1",20,0)
 ;I $G(DUZ("LOA"))<2 Q "-1^Insufficient Level of Assurance to allow visiting:  User not authenticated"
"RTN","XUESSO1",21,0)
 S NAME=$P(N,U)
"RTN","XUESSO1",22,0)
 I '$L(NAME) Q "-1^Insufficient info to allow visiting:  No User Name"
"RTN","XUESSO1",23,0)
 ;
"RTN","XUESSO1",24,0)
 S SITE=$$NS^XUAF4(DUZ(2)) ;Site is name^station#
"RTN","XUESSO1",25,0)
 I $P(SITE,U,2)="" Q "-1^Insufficient info to allow visiting:  Missing Station Number"
"RTN","XUESSO1",26,0)
 ;
"RTN","XUESSO1",27,0)
 S SSN=$P($G(^VA(200,DUZ,1)),U,9)
"RTN","XUESSO1",28,0)
 I $$SPECIAL($P(SITE,"^",2)) S SSN=999999999 ;Manila RO doesn't need SSN
"RTN","XUESSO1",29,0)
 I 'SSN Q "-1^Insufficient info to allow visiting:  Missing SSN"
"RTN","XUESSO1",30,0)
 I $E(SSN,10)="P" Q "-1^Insufficient info to allow visiting:  User has a pseudo SSN"
"RTN","XUESSO1",31,0)
 I '$$SSNCHECK(SSN) Q "-1^Insufficient info to allow visiting:  User does not have a valid SSN"
"RTN","XUESSO1",32,0)
 ;
"RTN","XUESSO1",33,0)
 S PHONE=$$PH
"RTN","XUESSO1",34,0)
 S X=SSN_U_NAME_U_SITE_U_DUZ
"RTN","XUESSO1",35,0)
 I $L(PHONE)>2&($L(PHONE<20)) S X=X_U_PHONE
"RTN","XUESSO1",36,0)
 S $P(X,U,7)=$P($G(^VA(200,DUZ,205.1)),U) ;p655 SecID
"RTN","XUESSO1",37,0)
 S $P(X,U,8)=$P($G(^VA(200,DUZ,501)),U) ;p655 Network Username
"RTN","XUESSO1",38,0)
 ;X=ssn^name^station name^station number^DUZ^phone^SecID^network username
"RTN","XUESSO1",39,0)
 Q X
"RTN","XUESSO1",40,0)
 ;
"RTN","XUESSO1",41,0)
PH() ; Try for a phone number or pager
"RTN","XUESSO1",42,0)
 N %,X
"RTN","XUESSO1",43,0)
 S %=""
"RTN","XUESSO1",44,0)
 S X=$G(^VA(200,DUZ,.13))
"RTN","XUESSO1",45,0)
 I '$L(X) Q ""
"RTN","XUESSO1",46,0)
 S %=$P(X,U,5) I $L(%)>6 Q %  ;Commercial #
"RTN","XUESSO1",47,0)
 S %=$P(X,U,2) I $L(%)>2 Q %  ;Office
"RTN","XUESSO1",48,0)
 S %=$P(X,U,8) I $L(%)>6 Q %  ;Digital Pager
"RTN","XUESSO1",49,0)
 S %=$P(X,U,7) I $L(%)>6 Q %  ;Pager
"RTN","XUESSO1",50,0)
 S %=$P(X,U,3) I $L(%)>2 Q %  ;Phone #3
"RTN","XUESSO1",51,0)
 S %=$P(X,U,4) I $L(%)>2 Q %  ;Phone #4
"RTN","XUESSO1",52,0)
 S %=$P(X,U,1) I $L(%)>2 Q %  ;Home Phone
"RTN","XUESSO1",53,0)
 Q "" ;Couldn't find one.
"RTN","XUESSO1",54,0)
 ;
"RTN","XUESSO1",55,0)
SPECIAL(SN) ;INTRINSIC. Special Manila RO site
"RTN","XUESSO1",56,0)
 ; Returns 1 if SN is "358"
"RTN","XUESSO1",57,0)
 Q 358=SN
"RTN","XUESSO1",58,0)
 ;
"RTN","XUESSO1",59,0)
PUT(DATIN) ;;Setup data from authenticating site GET() at receiving site
"RTN","XUESSO1",60,0)
 ;Called by OLDCAPRI^XUSBSE1 (Old Capri) and SETUP^XUSBSE1 (BSE)
"RTN","XUESSO1",61,0)
 ;Called by DIQ^DGROHLU (Sensitive Patient access) and REMOTE^XWB2HL7 (Visitor access via HL7)
"RTN","XUESSO1",62,0)
 ;Called by (unknown) (VSA/VistA.js)
"RTN","XUESSO1",63,0)
 ;Return: 0=fail, 1=OK
"RTN","XUESSO1",64,0)
 N NAME,NETWORK,NEWDUZ,PHONE,RMTDUZ,SECID,SITE,SITENUM,SSN,TODAY,XSITEIEN,XT,XUMF
"RTN","XUESSO1",65,0)
 I $G(DUZ("LOA"))="" S DUZ("LOA")=1
"RTN","XUESSO1",66,0)
 ;I $G(DUZ("LOA"))<2 Q 0  ;do not allow access if Level Of Assurance is low
"RTN","XUESSO1",67,0)
 I $G(DUZ("AUTHENTICATION"))="" S DUZ("AUTHENTICATION")="UNKNOWN"
"RTN","XUESSO1",68,0)
 S U="^",TODAY=$$HTFM^XLFDT($H),DT=$P(TODAY,"."),NEWDUZ=0
"RTN","XUESSO1",69,0)
 K ^TMP("DIERR",$J)
"RTN","XUESSO1",70,0)
 ;
"RTN","XUESSO1",71,0)
 S SSN=$P(DATIN,U,1),NAME=$P(DATIN,U,2),SITE=$P(DATIN,U,3)
"RTN","XUESSO1",72,0)
 S SITENUM=$P(DATIN,U,4),RMTDUZ=$P(DATIN,U,5),PHONE=$P(DATIN,U,6)
"RTN","XUESSO1",73,0)
 S SECID=$P(DATIN,U,7) ;p655
"RTN","XUESSO1",74,0)
 S NETWORK=$P(DATIN,U,8) ;p655
"RTN","XUESSO1",75,0)
 ;Format checks
"RTN","XUESSO1",76,0)
 I NAME'?1U.E1","1U.E Q 0
"RTN","XUESSO1",77,0)
 I SSN'?9N Q 0
"RTN","XUESSO1",78,0)
 I '$L(SITE)!('$L(SITENUM)) Q 0
"RTN","XUESSO1",79,0)
 S XUMF=1 D CHK^DIE(4,99,,SITENUM,.XT) I XT=U Q 0 ;p533
"RTN","XUESSO1",80,0)
 D CHK^DIE(200.06,1,,SITE,.XT) I XT=U Q 0 ;p533
"RTN","XUESSO1",81,0)
 I RMTDUZ'>0 Q 0 ;p337
"RTN","XUESSO1",82,0)
 ;Check if visitor is from a valid active site
"RTN","XUESSO1",83,0)
 S XSITEIEN=$$IEN^XUAF4(SITENUM) I XSITEIEN="" H 1 ;Q 0 ;Quit if authenticating VistA not in 
INSTITUTION file (#4)
"RTN","XUESSO1",84,0)
 ;I '$$ACTIVE^XUAF4(XSITEIEN) Q 0 ;Quit if authenticating VistA is not an active VA site (spoofed)
"RTN","XUESSO1",85,0)
 ;I $P($$NS^XUAF4(XSITEIEN),"^",1)'=SITE Q 0 ;Quit if authenticating VistA name and station number 
mismatch (spoofed)
"RTN","XUESSO1",86,0)
 ;Get a LOCK. Block if can't get.
"RTN","XUESSO1",87,0)
 L +^VA(200,"HL7"):10 Q:'$T 0
"RTN","XUESSO1",88,0)
 S XT=$$TALL($G(DUZ,0)) L -^VA(200,"HL7")
"RTN","XUESSO1",89,0)
 I XT Q $$SET(NEWDUZ) ;Return 1 if OK.
"RTN","XUESSO1",90,0)
 Q 0
"RTN","XUESSO1",91,0)
 ;
"RTN","XUESSO1",92,0)
TALL(DUZ) ;INTRINSIC. Test for existing user or adds a new one
"RTN","XUESSO1",93,0)
 ; ZEXCEPT: NAME,NEWDUZ,PHONE,RMTDUZ,SITE,SITENUM,SSN,XSSN,TODAY,SECID,NETWORK ;global 
variables within this routine
"RTN","XUESSO1",94,0)
 ; ZEXCEPT: DIC ;turn off DIC(0) for ^XUA4A7 (work around)
"RTN","XUESSO1",95,0)
 N FLAG,NEWREC,XUIAM
"RTN","XUESSO1",96,0)
 S FLAG=0,DUZ(0)="@" ;Make sure we can add the entry
"RTN","XUESSO1",97,0)
 S XUIAM=1 ;Do not trigger IAM updates
"RTN","XUESSO1",98,0)
 ;See if match SECID. Only use for lookup. Do not load SECID's.
"RTN","XUESSO1",99,0)
 I $L(SECID) D
"RTN","XUESSO1",100,0)
 . S NEWDUZ=+$$SECMATCH^XUESSO2(SECID) Q:NEWDUZ<1  ;p655
"RTN","XUESSO1",101,0)
 . I '$D(^VA(200,NEWDUZ,8910,"B",SITENUM)) D VISM
"RTN","XUESSO1",102,0)
 . D ADDW,UPDT
"RTN","XUESSO1",103,0)
 . S FLAG=1,DUZ(0)=$P($G(^VA(200,NEWDUZ,0)),U,4)
"RTN","XUESSO1",104,0)
 . Q
"RTN","XUESSO1",105,0)
 I FLAG Q 1 ;Quit here if we found a match on SECID
"RTN","XUESSO1",106,0)
 ;See if the SSN is in the NPF cross reference
"RTN","XUESSO1",107,0)
 I $D(^VA(200,"SSN",SSN)),$$SSNCHECK(SSN),'$$SPECIAL(SITENUM) D
"RTN","XUESSO1",108,0)
 . N XUEIEN,XUEAUSER
"RTN","XUESSO1",109,0)
 . S XUEIEN=0,NEWDUZ=0
"RTN","XUESSO1",110,0)
 . F  S XUEIEN=$O(^VA(200,"SSN",SSN,XUEIEN)) Q:(XUEIEN="")!(NEWDUZ>0)  D
"RTN","XUESSO1",111,0)
 . . N XUENAME S XUENAME=$P($G(^VA(200,XUEIEN,0)),U)
"RTN","XUESSO1",112,0)
 . . S NEWDUZ=XUEIEN
"RTN","XUESSO1",113,0)
 . . ;Update name if names don't match, user has visited before, and user is not an active local user
"RTN","XUESSO1",114,0)
 . . I 
(XUENAME'=NAME)&(XUEIEN=$O(^VA(200,"AVISIT",SITENUM,RMTDUZ,0)))&(('$$ACTIVE^XUSER(XUEIE
N))) D ADDN
"RTN","XUESSO1",115,0)
 . Q:NEWDUZ'>0
"RTN","XUESSO1",116,0)
 . I '$D(^VA(200,NEWDUZ,8910,"B",SITENUM)) D VISM
"RTN","XUESSO1",117,0)
 . D ADDW,ADDI,UPDT
"RTN","XUESSO1",118,0)
 . S FLAG=1,DUZ(0)=$P($G(^VA(200,NEWDUZ,0)),U,4)
"RTN","XUESSO1",119,0)
 . Q
"RTN","XUESSO1",120,0)
 I FLAG Q 1 ;Quit here if we found a match for SSN
"RTN","XUESSO1",121,0)
 ;See if in the AVISIT cross reference (Manila only)
"RTN","XUESSO1",122,0)
 I $$SPECIAL(SITENUM) D
"RTN","XUESSO1",123,0)
 . S NEWDUZ=$O(^VA(200,"AVISIT",SITENUM,RMTDUZ,0))
"RTN","XUESSO1",124,0)
 . Q:NEWDUZ'>0  ;User must have visited from Manila at least once to be found by this test
"RTN","XUESSO1",125,0)
 . D ADDW,ADDI,UPDT S FLAG=1,DUZ(0)=$P($G(^VA(200,NEWDUZ,0)),U,4)
"RTN","XUESSO1",126,0)
 . Q
"RTN","XUESSO1",127,0)
 I FLAG Q 1 ;Quit here if we found a match for AVISIT
"RTN","XUESSO1",128,0)
 ;Try for a NAME match in "B"
"RTN","XUESSO1",129,0)
 N XUEIEN,XUESSN
"RTN","XUESSO1",130,0)
 S NAME=$$UP^XLFSTR(NAME)
"RTN","XUESSO1",131,0)
 I $D(^VA(200,"B",NAME)) D
"RTN","XUESSO1",132,0)
 . S XUEIEN=0,NEWDUZ=0
"RTN","XUESSO1",133,0)
 . F  S XUEIEN=$O(^VA(200,"B",NAME,XUEIEN)) Q:(XUEIEN="")!(NEWDUZ>0)  D
"RTN","XUESSO1",134,0)
 . . S XUESSN=$P($G(^VA(200,XUEIEN,1)),U,9)
"RTN","XUESSO1",135,0)
 . . I (XUESSN'=SSN)&($L(XUESSN)>8) Q  ;Do not use if name has a different SSN
"RTN","XUESSO1",136,0)
 . . S NEWDUZ=XUEIEN
"RTN","XUESSO1",137,0)
 . I NEWDUZ>0 D
"RTN","XUESSO1",138,0)
 . . D ADDS
"RTN","XUESSO1",139,0)
 . . I '$D(^VA(200,NEWDUZ,8910,"B",SITENUM)) D VISM
"RTN","XUESSO1",140,0)
 . . D ADDW,ADDI,UPDT
"RTN","XUESSO1",141,0)
 . . S FLAG=1,DUZ(0)=$P($G(^VA(200,NEWDUZ,0)),U,4)
"RTN","XUESSO1",142,0)
 . Q
"RTN","XUESSO1",143,0)
 I FLAG Q 1 ;Quit here if we found an exact match for NAME (w/o SSN)
"RTN","XUESSO1",144,0)
 ;
"RTN","XUESSO1",145,0)
 ;I DUZ("LOA")=1 Q 0  ;Do not add user if Level Of Assurance is low
"RTN","XUESSO1",146,0)
 ;I $G(DUZ("REMAPP"))="^MDWS" Q 0  ;Do not add user if MDWS access
"RTN","XUESSO1",147,0)
 I $G(DUZ("REMAPP"))="^MDWS" H $E(DT,1,3)-315  ;Discourage deprecated MDWS access
"RTN","XUESSO1",148,0)
 ;
"RTN","XUESSO1",149,0)
 ;We didn't find anybody under SecID,SSN,VISITED FROM, or NAME so we add a new user
"RTN","XUESSO1",150,0)
 S DIC(0)="" ;Turn off ^XUA4A7 (work around)
"RTN","XUESSO1",151,0)
 ;Put the name in the .01 field first.
"RTN","XUESSO1",152,0)
 D ADDU ;ADDU will set NEWDUZ
"RTN","XUESSO1",153,0)
 I NEWDUZ=0 Q 0  ;If NEWDUZ is still 0, the User add didn't work so exit.
"RTN","XUESSO1",154,0)
 D ADDS,ADDA ;(p337) Add SSN and "VISITOR" Alias.
"RTN","XUESSO1",155,0)
 D ADDW,ADDI ; Add NETWORK USERNAME and SSO attributes
"RTN","XUESSO1",156,0)
 D VISM,UPDT ; Fill in the  VISITED FROM multiple
"RTN","XUESSO1",157,0)
 I NEWDUZ=0 Q 0 ;Couldn't update user
"RTN","XUESSO1",158,0)
 I $D(^TMP("DIERR",$J)) Q 0  ;FileMan Error
"RTN","XUESSO1",159,0)
 ;
"RTN","XUESSO1",160,0)
 S FLAG=$$BULL(NAME,NEWDUZ,SITE,SITENUM,RMTDUZ,PHONE,TODAY)
"RTN","XUESSO1",161,0)
 S DUZ(0)=$P($G(^VA(200,NEWDUZ,0)),U,4)
"RTN","XUESSO1",162,0)
 Q 1  ;Every thing OK
"RTN","XUESSO1",163,0)
 ;
"RTN","XUESSO1",164,0)
SET(NEWDUZ) ;INTRINSIC. Set the user up to go
"RTN","XUESSO1",165,0)
 ; ZEXCEPT: RMTDUZ,SITENUM ;global variables within this routine
"RTN","XUESSO1",166,0)
 ;Return: 0=fail, 1=OK
"RTN","XUESSO1",167,0)
 Q:NEWDUZ'>0 0
"RTN","XUESSO1",168,0)
 N XUSER,XOPT
"RTN","XUESSO1",169,0)
 S DUZ=NEWDUZ,U="^",DUZ("VISITOR")=SITENUM_U_RMTDUZ ;p533
"RTN","XUESSO1",170,0)
 D DUZ^XUS1A
"RTN","XUESSO1",171,0)
 Q 1
"RTN","XUESSO1",172,0)
 ;
"RTN","XUESSO1",173,0)
ADDU ;SR. Add a new name to the New Person File
"RTN","XUESSO1",174,0)
 ; ZEXCEPT: FDR,NAME,NEWDUZ,NEWREC ;global variables within this routine
"RTN","XUESSO1",175,0)
 N DD,DO,DIC,DA,X,Y
"RTN","XUESSO1",176,0)
 S NEWDUZ=0
"RTN","XUESSO1",177,0)
 S DIC="^VA(200,",DIC(0)="F",X=NAME,NEWREC=1 ;p533
"RTN","XUESSO1",178,0)
 D FILE^DICN
"RTN","XUESSO1",179,0)
 S:Y>0 NEWDUZ=+Y
"RTN","XUESSO1",180,0)
 Q
"RTN","XUESSO1",181,0)
 ;
"RTN","XUESSO1",182,0)
ADDS ;SR. Add a SSN to the New Person File
"RTN","XUESSO1",183,0)
 ; ZEXCEPT: FDR,NEWDUZ,SSN,SITENUM ;global variables within this routine
"RTN","XUESSO1",184,0)
 N IEN
"RTN","XUESSO1",185,0)
 Q:$$SPECIAL(SITENUM)  ;don't add SSN if from Manila
"RTN","XUESSO1",186,0)
 Q:$D(^VA(200,"SSN",SSN))  ;don't try to add a duplicate SSN
"RTN","XUESSO1",187,0)
 Q:'$$SSNCHECK(SSN)  ;only add a valid SSN
"RTN","XUESSO1",188,0)
 S IEN=NEWDUZ_","
"RTN","XUESSO1",189,0)
 S FDR(200,IEN,9)=SSN
"RTN","XUESSO1",190,0)
 ;Do update for all data in UPDT
"RTN","XUESSO1",191,0)
 Q
"RTN","XUESSO1",192,0)
 ;
"RTN","XUESSO1",193,0)
ADDI ;SR. Add SSO attributes to the New Person File
"RTN","XUESSO1",194,0)
 ; ZEXCEPT: FDR,NEWDUZ,SECID ;global variables within this routine
"RTN","XUESSO1",195,0)
 N IEN
"RTN","XUESSO1",196,0)
 Q:'$L(SECID)  ;need SECID for SSO
"RTN","XUESSO1",197,0)
 S IEN=NEWDUZ_","
"RTN","XUESSO1",198,0)
 I $P($G(^VA(200,NEWDUZ,205)),U,1)="" S FDR(200,IEN,205.1)=SECID ;SECID
"RTN","XUESSO1",199,0)
 I $P($G(^VA(200,NEWDUZ,205)),U,2)="" S FDR(200,IEN,205.2)=$P($G(^XTV(8989.3,1,200)),U,2) ;Subject 
Organization
"RTN","XUESSO1",200,0)
 I $P($G(^VA(200,NEWDUZ,205)),U,3)="" S FDR(200,IEN,205.3)=$P($G(^XTV(8989.3,1,200)),U,3) ;Subject 
Organization ID
"RTN","XUESSO1",201,0)
 I $P($G(^VA(200,NEWDUZ,205)),U,4)="" S FDR(200,IEN,205.4)=SECID ;Unique User ID
"RTN","XUESSO1",202,0)
 ;Do update for all data in UPDT
"RTN","XUESSO1",203,0)
 Q
"RTN","XUESSO1",204,0)
 ;
"RTN","XUESSO1",205,0)
ADDN ;SR. Update the NAME in the New Person File
"RTN","XUESSO1",206,0)
 ; ZEXCEPT: FDR,NEWDUZ,NAME,RMTDUZ,SITENUM ;global variables within this routine
"RTN","XUESSO1",207,0)
 N IEN
"RTN","XUESSO1",208,0)
 Q:NAME=$P($G(^VA(200,NEWDUZ,0)),U,1)  ; name is unchanged, do nothing
"RTN","XUESSO1",209,0)
 I NEWDUZ'=$O(^VA(200,"AVISIT",SITENUM,RMTDUZ,0)) Q  ; user hasn't visited before, so this is not a 
valid name change
"RTN","XUESSO1",210,0)
 S IEN=NEWDUZ_","
"RTN","XUESSO1",211,0)
 S FDR(200,IEN,.01)=NAME
"RTN","XUESSO1",212,0)
 ;Do update for all data in UPDT
"RTN","XUESSO1",213,0)
 Q
"RTN","XUESSO1",214,0)
 ;
"RTN","XUESSO1",215,0)
ADDA ;SR. Add a new Alias to file 200.04
"RTN","XUESSO1",216,0)
 ; ZEXCEPT: FDR,NEWDUZ ;global variables within this routine
"RTN","XUESSO1",217,0)
 N IEN
"RTN","XUESSO1",218,0)
 Q:$D(^VA(200,NEWDUZ,3,"B","VISITOR"))  ; Quit if user is already marked as visitor
"RTN","XUESSO1",219,0)
 S IEN="+2,"_NEWDUZ_","
"RTN","XUESSO1",220,0)
 S FDR(200.04,IEN,.01)="VISITOR"
"RTN","XUESSO1",221,0)
 ;Do update for all data in UPDT
"RTN","XUESSO1",222,0)
 Q
"RTN","XUESSO1",223,0)
 ;
"RTN","XUESSO1",224,0)
ADDW ;SR. Add NETWORK USERNAME to the New Person File
"RTN","XUESSO1",225,0)
 ; ZEXCEPT: FDR,NEWDUZ,NETWORK ;global variables within this routine
"RTN","XUESSO1",226,0)
 N IEN
"RTN","XUESSO1",227,0)
 Q:$G(^VA(200,NEWDUZ,501))'=""  ; Quit if user already has a NETWORK USERNAME
"RTN","XUESSO1",228,0)
 Q:$L($G(NETWORK))<12  ; Quit if NETWORK USERNAME is too short
"RTN","XUESSO1",229,0)
 S IEN=NEWDUZ_","
"RTN","XUESSO1",230,0)
 S FDR(200,IEN,501.1)=$G(NETWORK)
"RTN","XUESSO1",231,0)
 ;Do update for all data in UPDT
"RTN","XUESSO1",232,0)
 Q
"RTN","XUESSO1",233,0)
 ;
"RTN","XUESSO1",234,0)
VISM ;SR. Create a multiple for this site number in the VISITED FROM file
"RTN","XUESSO1",235,0)
 ; ZEXCEPT: FDR,NEWDUZ,RMTDUZ,SITE,SITENUM,TODAY ;global variables within this routine
"RTN","XUESSO1",236,0)
 N IEN
"RTN","XUESSO1",237,0)
 S IEN="+3,"_NEWDUZ_","
"RTN","XUESSO1",238,0)
 S FDR(200.06,IEN,.01)=SITENUM
"RTN","XUESSO1",239,0)
 S FDR(200.06,IEN,1)=SITE
"RTN","XUESSO1",240,0)
 S FDR(200.06,IEN,2)=RMTDUZ
"RTN","XUESSO1",241,0)
 S FDR(200.06,IEN,3)=TODAY
"RTN","XUESSO1",242,0)
 ;Do update for all data in UPDT
"RTN","XUESSO1",243,0)
 Q
"RTN","XUESSO1",244,0)
 ;
"RTN","XUESSO1",245,0)
UPDT ;SR. Update all data fields
"RTN","XUESSO1",246,0)
 ; Sets: NEWDUZ=0 if failed to complete update
"RTN","XUESSO1",247,0)
 ; ZEXCEPT: FDR,NAME,NEWDUZ,SITE,SITENUM,PHONE,TODAY,DATIN,NEWREC ;global variables within 
this routine
"RTN","XUESSO1",248,0)
 N IEN,FDQ
"RTN","XUESSO1",249,0)
 I $D(FDR(200.06)) S IEN=$O(FDR(200.06,""))
"RTN","XUESSO1",250,0)
 E  S IEN=$O(^VA(200,NEWDUZ,8910,"B",SITENUM,0))_","_NEWDUZ_","
"RTN","XUESSO1",251,0)
 S FDR(200.06,IEN,4)=TODAY
"RTN","XUESSO1",252,0)
 I $D(PHONE),($L(PHONE)>4) S FDR(200.06,IEN,5)=PHONE ;p466 Update the phone each time
"RTN","XUESSO1",253,0)
 I $D(SITE) S FDR(200.06,IEN,1)=SITE ;p655 Update the site each time (name changes in INSTITUTION file)
"RTN","XUESSO1",254,0)
 K IEN D UPDATE^DIE("E","FDR","IEN") ;File all the data
"RTN","XUESSO1",255,0)
 I $D(^TMP("DIERR",$J)) D  Q
"RTN","XUESSO1",256,0)
 . N DIK,DA,Y
"RTN","XUESSO1",257,0)
 . I $D(NEWREC) S DIK="^VA(200,",DA=NEWDUZ D ^DIK ;Remove partial entry ;p533
"RTN","XUESSO1",258,0)
 . S NEWDUZ=0 ;Tell failed
"RTN","XUESSO1",259,0)
 Q
"RTN","XUESSO1",260,0)
 ;
"RTN","XUESSO1",261,0)
BULL(NAME,NEWDUZ,SITE,SITENUM,RMTDUZ,PHONE,TODAY) ;INTRINSIC. Send local bulletin if user 
added
"RTN","XUESSO1",262,0)
 ; Returns: 0 if failed to send bulletin, 1 if success
"RTN","XUESSO1",263,0)
 ; ZEXCEPT: XTMUNIT ;set for unit testing
"RTN","XUESSO1",264,0)
 N XMB
"RTN","XUESSO1",265,0)
 I ($G(NAME)="")!($G(NEWDUZ)="")!($G(SITE)="")!($G(SITENUM)="") Q 0
"RTN","XUESSO1",266,0)
 I ($G(RMTDUZ)="")!($G(PHONE)="")!($G(TODAY)="") Q 0
"RTN","XUESSO1",267,0)
 S XMB="XUVISIT"
"RTN","XUESSO1",268,0)
 S XMB(1)=$$FMTE^XLFDT(TODAY)
"RTN","XUESSO1",269,0)
 S XMB(2)=NAME,XMB(3)=NEWDUZ,XMB(4)=SITE
"RTN","XUESSO1",270,0)
 S XMB(5)=SITENUM,XMB(6)=RMTDUZ,XMB(7)=PHONE
"RTN","XUESSO1",271,0)
 I '$D(XTMUNIT) D ^XMB
"RTN","XUESSO1",272,0)
 Q 1
"RTN","XUESSO1",273,0)
 ;
"RTN","XUESSO1",274,0)
SSNCHECK(SSN) ;INTRINSIC. Check for valid SSN
"RTN","XUESSO1",275,0)
 ; Input: SSN in format "nnnnnnnnn" or "nnn-nn-nnnn"
"RTN","XUESSO1",276,0)
 ; Returns: 0 if SSN is invalid, 1 if success
"RTN","XUESSO1",277,0)
 ; Valid SSN range 001-01-0001 to 899-99-9999 with exceptions (rule as of 2011)
"RTN","XUESSO1",278,0)
 ; Valid Individual Taxpayer Identification Number range 900-01-0001 to 999-99-9999 with exceptions 
(rule as of 1966)
"RTN","XUESSO1",279,0)
 N X
"RTN","XUESSO1",280,0)
 I $$PROD^XUPROD()=0 Q 1  ;allow use of invalid SSNs in development accounts
"RTN","XUESSO1",281,0)
 S X=$TR(SSN,"-")
"RTN","XUESSO1",282,0)
 I $L(X)'=9 Q 0
"RTN","XUESSO1",283,0)
 I $E(X,1,3)'>0 Q 0   ;1st 3 digits cannot be 000
"RTN","XUESSO1",284,0)
 I $E(X,4,5)'>0 Q 0   ;digits 4-5 cannot be 00
"RTN","XUESSO1",285,0)
 I $E(X,6,9)'>0 Q 0   ;digits 6-9 cannot be 0000
"RTN","XUESSO1",286,0)
 I $E(X,1,3)=666 Q 0  ;1st 3 digits cannot be 666
"RTN","XUESSO1",287,0)
 I (X>987654319)&(X<987654330) Q 0  ;SSN range reserved for advertising
"RTN","XUESSO1",288,0)
 I ($E(X,1,3)>899)&($E(X,4,5)=89) Q 0  ;digits 4-5 of ITIN cannot be 89
"RTN","XUESSO1",289,0)
 I ($E(X,1,3)>899)&($E(X,4,5)=93) Q 0  ;digits 4-5 of ITIN cannot be 93
"RTN","XUESSO1",290,0)
 Q 1
"RTN","XUESSO2")
0^12^B117714262^B108993229
"RTN","XUESSO2",1,0)
XUESSO2 ;ISD/HGW Enhanced Single Sign-On Utilities ;08/25/15  10:48
"RTN","XUESSO2",2,0)
 ;;8.0;KERNEL;**655,659**;Jul 10, 1995;Build 22
"RTN","XUESSO2",3,0)
 ;Per VA Directive 6402, this routine should not be modified.
"RTN","XUESSO2",4,0)
 ;
"RTN","XUESSO2",5,0)
 ; This utility will identify a VistA user for auditing and HIPAA requirements.
"RTN","XUESSO2",6,0)
 ;   NONE of the fields listed below can contain a caret (^) character as it is used as a delimiter in VistA!
"RTN","XUESSO2",7,0)
 ;
"RTN","XUESSO2",8,0)
 ; $$FINDUSER() - At least one of the following attributes is required to uniquely identify an existing user 
in the
"RTN","XUESSO2",9,0)
 ;                NEW PERSON file (#200):
"RTN","XUESSO2",10,0)
 ;
"RTN","XUESSO2",11,0)
 ;   XATR(7) = unique Security ID [SecID, assigned by Identity and Access Management]
"RTN","XUESSO2",12,0)
 ;   XATR(8) = unique National Provider Identifier [assigned by Centers for Medicare and Medicaid 
Services (CMS)]
"RTN","XUESSO2",13,0)
 ;   XATR(9) = unique Social Security (SSN) or Taxpayer Identification Number (TIN) [assigned by the Social 
Security Administration]
"RTN","XUESSO2",14,0)
 ;   XATR(2) and XATR(3) = combination of a unique Subject Organization ID (OID) with a Unique User ID 
(UID) [see below]
"RTN","XUESSO2",15,0)
 ;
"RTN","XUESSO2",16,0)
 ; $$ADDUSER() - If an existing user is not found in the NEW PERSON file (#200), then the following 
minimum attributes
"RTN","XUESSO2",17,0)
 ;               are required to provision a new user:
"RTN","XUESSO2",18,0)
 ;
"RTN","XUESSO2",19,0)
 ;   XATR(1) = Subject Organization [free text, 3-50 characters]
"RTN","XUESSO2",20,0)
 ;   XATR(2) = Subject Organization ID [free text, 1-50 characters, unique to Subject Organization]
"RTN","XUESSO2",21,0)
 ;   XATR(3) = Unique User ID [free text, 1-40 characters, unique within OID]
"RTN","XUESSO2",22,0)
 ;   XATR(4) = Subject ID [person's name, to be entered into the NAME field (#.01) of the NEW PERSON 
file (#200)]
"RTN","XUESSO2",23,0)
 ;
"RTN","XUESSO2",24,0)
 ; The following attributes are optional for adding or updating a user, but may be required by a particular 
VistA application
"RTN","XUESSO2",25,0)
 ;               for further Identity and Access Management:
"RTN","XUESSO2",26,0)
 ;
"RTN","XUESSO2",27,0)
 ;   XATR(5) = Application ID [Security Phrase to identify and authenticate the client application and 
establish the context option]
"RTN","XUESSO2",28,0)
 ;   XATR(6) = Network Username [Active Directory Login]
"RTN","XUESSO2",29,0)
 ;   XATR(9) = unique Social Security (SSN) or Taxpayer Identification Number (TIN) [assigned by the Social 
Security Administration]
"RTN","XUESSO2",30,0)
 ;   XATR(10)= AD UPN [Active Directory User Principle Name (UPN)]
"RTN","XUESSO2",31,0)
 ;   XATR(11)= E-Mail Address
"RTN","XUESSO2",32,0)
 Q
"RTN","XUESSO2",33,0)
 ;
"RTN","XUESSO2",34,0)
FINDUSER(XATR) ;Function. Find user using minimum attributes for user identification
"RTN","XUESSO2",35,0)
 ; Input:  XATR    = Array containing user attributes (see above).
"RTN","XUESSO2",36,0)
 ; Return: Fail    = "-1^Error Message"
"RTN","XUESSO2",37,0)
 ;         Success = IEN of NEW PERSON file (#200) entry (Note: this routine will NOT set DUZ to the 
identified IEN)
"RTN","XUESSO2",38,0)
 ;
"RTN","XUESSO2",39,0)
 N TODAY,DT,IEN,DIC,XUNAME,ERRMSG
"RTN","XUESSO2",40,0)
 S U="^",TODAY=$$HTFM^XLFDT($H),DT=$P(TODAY,"."),ERRMSG=""
"RTN","XUESSO2",41,0)
 ; Check for unique identifier (SecID, NPI, SSN, or OID+UID)
"RTN","XUESSO2",42,0)
 I ($G(XATR(7))="")&($G(XATR(8))="")&($G(XATR(9))="")&(($G(XATR(2))="")&($G(XATR(3))="")) Q "-
1^Array does not contain a unique identifier"
"RTN","XUESSO2",43,0)
 ; Format user attributes to match FileMan fields
"RTN","XUESSO2",44,0)
 S XATR(1)=$$TITLE^XLFSTR($E($G(XATR(1)),1,50))                      ;Subject Organization
"RTN","XUESSO2",45,0)
 S XATR(2)=$$LOW^XLFSTR($E($G(XATR(2)),1,50))                        ;Subject Organization ID
"RTN","XUESSO2",46,0)
 S XATR(3)=$TR($$LOW^XLFSTR($E($G(XATR(3)),1,40)),"^","%")           ;Unique User ID
"RTN","XUESSO2",47,0)
 I $G(XATR(4))'="" D  Q:ERRMSG'="" ERRMSG
"RTN","XUESSO2",48,0)
 . S XUNAME=XATR(4) S XATR(4)=$$FORMAT^XLFNAME7(.XUNAME,3,35,,0,,,2) ;Subject ID converted to 
standard format
"RTN","XUESSO2",49,0)
 . I $G(XATR(4))'?1U.E1","1U.E S ERRMSG="-1^Subject ID could not be converted to 'LAST,FIRST MIDDLE 
SUFFIX' VistA standard format"
"RTN","XUESSO2",50,0)
 S XATR(6)=$$UP^XLFSTR($E($G(XATR(6)),1,50))                         ;AD Network Username
"RTN","XUESSO2",51,0)
 S XATR(7)=$TR($E($G(XATR(7)),1,40),"^","%")                         ;SecID
"RTN","XUESSO2",52,0)
 Q $$TALL(.XATR)
"RTN","XUESSO2",53,0)
 ;
"RTN","XUESSO2",54,0)
TALL(XATR) ;Function. Find an existing user.
"RTN","XUESSO2",55,0)
 N OID,UID,SECID,NPI,SSN,NEWDUZ,ERRMSG,AOIUID,X,Y,Z
"RTN","XUESSO2",56,0)
 S X=$ST($ST-1,"PLACE"),Y=$P(X,"+"),Z=$P(X,"^",2),X=Y_"^"_$P(Z," ")
"RTN","XUESSO2",57,0)
 I X'="FINDUSER^XUESSO2" Q "-1^Not authorized"
"RTN","XUESSO2",58,0)
 I $G(DUZ("LOA"))<2 Q "-1^Not authorized"
"RTN","XUESSO2",59,0)
 S OID=$G(XATR(2))
"RTN","XUESSO2",60,0)
 S UID=$G(XATR(3))
"RTN","XUESSO2",61,0)
 S SECID=$G(XATR(7))
"RTN","XUESSO2",62,0)
 S NPI=$G(XATR(8))
"RTN","XUESSO2",63,0)
 S SSN=$G(XATR(9))
"RTN","XUESSO2",64,0)
 S ERRMSG="",NEWDUZ=0,Y=0
"RTN","XUESSO2",65,0)
 ;See if match SECID, to be assigned by Identification and Access Management (IAM) services.
"RTN","XUESSO2",66,0)
 I $L(SECID)>0 D  Q:ERRMSG'="" ERRMSG
"RTN","XUESSO2",67,0)
 . S Y=$$SECMATCH(SECID) Q:Y<1
"RTN","XUESSO2",68,0)
 . I NPI'="" D  Q:ERRMSG'=""
"RTN","XUESSO2",69,0)
 . . I NPI'=$P($G(^VA(200,Y,"NPI")),U) S ERRMSG="-1^NPI mismatch for user ID'd by SecID" Q
"RTN","XUESSO2",70,0)
 . I SSN'="" D  Q:ERRMSG'=""
"RTN","XUESSO2",71,0)
 . . I SSN'=$P($G(^VA(200,Y,1)),U,9) S ERRMSG="-1^SSN mismatch for user ID'd by SecID" Q
"RTN","XUESSO2",72,0)
 . S NEWDUZ=Y
"RTN","XUESSO2",73,0)
 . S ERRMSG=$$UPDU(.XATR,NEWDUZ) ; Update fields if changes are needed
"RTN","XUESSO2",74,0)
 . Q
"RTN","XUESSO2",75,0)
 I NEWDUZ>0 Q NEWDUZ ;Quit here if we found a match on SECID
"RTN","XUESSO2",76,0)
 ;See if match NPI
"RTN","XUESSO2",77,0)
 I $L(NPI)>0 D  Q:ERRMSG'="" ERRMSG
"RTN","XUESSO2",78,0)
 . S Y=+$O(^VA(200,"ANPI",NPI,0)) Q:Y<1
"RTN","XUESSO2",79,0)
 . I SECID'="" D  Q:ERRMSG'=""
"RTN","XUESSO2",80,0)
 . . I $$SECMATCH(SECID)<1 S ERRMSG="-1^SecID mismatch for user ID'd by NPI" Q
"RTN","XUESSO2",81,0)
 . I SSN'="" D  Q:ERRMSG'=""
"RTN","XUESSO2",82,0)
 . . I SSN'=$P($G(^VA(200,Y,1)),U,9) S ERRMSG="-1^SSN mismatch for user ID'd by NPI" Q
"RTN","XUESSO2",83,0)
 . S NEWDUZ=Y
"RTN","XUESSO2",84,0)
 . S ERRMSG=$$UPDU(.XATR,NEWDUZ) ; Update fields if changes are needed
"RTN","XUESSO2",85,0)
 . Q
"RTN","XUESSO2",86,0)
 I NEWDUZ>0 Q NEWDUZ ;Quit here if we found a match on NPI
"RTN","XUESSO2",87,0)
 ;See if match SSN
"RTN","XUESSO2",88,0)
 I $L(SSN)>0 D  Q:ERRMSG'="" ERRMSG
"RTN","XUESSO2",89,0)
 . S Y=+$O(^VA(200,"SSN",SSN,0)) Q:Y<1
"RTN","XUESSO2",90,0)
 . I SECID'="" D  Q:ERRMSG'=""
"RTN","XUESSO2",91,0)
 . . I $$SECMATCH(SECID)<1 S ERRMSG="-1^SecID mismatch for user ID'd by SSN" Q
"RTN","XUESSO2",92,0)
 . I NPI'="" D  Q:ERRMSG'=""
"RTN","XUESSO2",93,0)
 . . I NPI'=$P($G(^VA(200,Y,"NPI")),U) S ERRMSG="-1^NPI mismatch for user ID'd by SSN" Q
"RTN","XUESSO2",94,0)
 . S NEWDUZ=Y
"RTN","XUESSO2",95,0)
 . S ERRMSG=$$UPDU(.XATR,NEWDUZ) ; Update fields if changes are needed
"RTN","XUESSO2",96,0)
 . Q
"RTN","XUESSO2",97,0)
 I NEWDUZ>0 Q NEWDUZ ;Quit here if we found a match on SSN
"RTN","XUESSO2",98,0)
 ;See if match OID+UID ("AOIUID" cross-reference).
"RTN","XUESSO2",99,0)
 S Y=$$AOIUID(OID,UID) I Y>0 D  Q:ERRMSG'="" ERRMSG
"RTN","XUESSO2",100,0)
 . I SECID'="" D  Q:ERRMSG'=""
"RTN","XUESSO2",101,0)
 . . I $$SECMATCH(SECID)<1 S ERRMSG="-1^SecID mismatch for user ID'd by OID+UID" Q
"RTN","XUESSO2",102,0)
 . I NPI'="" D  Q:ERRMSG'=""
"RTN","XUESSO2",103,0)
 . . I NPI'=$P($G(^VA(200,Y,"NPI")),U) S ERRMSG="-1^NPI mismatch for user ID'd by OID+UID" Q
"RTN","XUESSO2",104,0)
 . I SSN'="" D  Q:ERRMSG'=""
"RTN","XUESSO2",105,0)
 . . I SSN'=$P($G(^VA(200,Y,1)),U,9) S ERRMSG="-1^SSN mismatch for user ID'd by OID+UID" Q
"RTN","XUESSO2",106,0)
 . S NEWDUZ=Y
"RTN","XUESSO2",107,0)
 . S ERRMSG=$$UPDU(.XATR,NEWDUZ) ; Update fields if changes are needed
"RTN","XUESSO2",108,0)
 . Q
"RTN","XUESSO2",109,0)
 I NEWDUZ>0 Q NEWDUZ ;Quit here if we found a match on OID+UID
"RTN","XUESSO2",110,0)
 Q "-1^User not found"
"RTN","XUESSO2",111,0)
 ;
"RTN","XUESSO2",112,0)
ADDUSER(XATR) ;Function. Add user using minimum attributes for user identification
"RTN","XUESSO2",113,0)
 ; Input:  XATR    = Array containing user attributes (see above).
"RTN","XUESSO2",114,0)
 ; Return: Fail    = "-1^Error Message"
"RTN","XUESSO2",115,0)
 ;         Success = IEN of NEW PERSON file (#200) entry (Note: this routine will NOT set DUZ to the 
identified IEN)
"RTN","XUESSO2",116,0)
 ;
"RTN","XUESSO2",117,0)
 N SID,NEWDUZ,ERRMSG
"RTN","XUESSO2",118,0)
 I '$$AUTH() Q "-1^Not an authorized calling routine"
"RTN","XUESSO2",119,0)
 I $G(DUZ("LOA"))<2 Q "-1^Not authorized"
"RTN","XUESSO2",120,0)
 S ERRMSG=""
"RTN","XUESSO2",121,0)
 ;Minimum 4 Attributes are required to add a new user
"RTN","XUESSO2",122,0)
 I $G(XATR(1))="" Q "-1^Subject Organization is required to add a new user"
"RTN","XUESSO2",123,0)
 I $G(XATR(2))="" Q "-1^Subject Organization ID is required to add a new user"
"RTN","XUESSO2",124,0)
 I $G(XATR(3))="" Q "-1^Unique User ID is required to add a new user"
"RTN","XUESSO2",125,0)
 I $G(XATR(4))="" Q "-1^Subject ID is required to add a new user"
"RTN","XUESSO2",126,0)
 ; Format user attributes to match FileMan fields
"RTN","XUESSO2",127,0)
 S XATR(1)=$$TITLE^XLFSTR($E($G(XATR(1)),1,50))                      ;Subject Organization
"RTN","XUESSO2",128,0)
 S XATR(2)=$$LOW^XLFSTR($E($G(XATR(2)),1,50))                        ;Subject Organization ID
"RTN","XUESSO2",129,0)
 S XATR(3)=$TR($$LOW^XLFSTR($E($G(XATR(3)),1,40)),"^","%")           ;Unique User ID
"RTN","XUESSO2",130,0)
 I $G(XATR(4))'="" D  Q:ERRMSG'="" ERRMSG
"RTN","XUESSO2",131,0)
 . S SID=XATR(4) S XATR(4)=$$FORMAT^XLFNAME7(.SID,3,35,,0,,,2) ; Subject ID converted to standard 
format
"RTN","XUESSO2",132,0)
 . I $G(XATR(4))'?1U.E1","1U.E S ERRMSG="-1^Subject ID could not be converted to 'LAST,FIRST MIDDLE 
SUFFIX' VistA standard format"
"RTN","XUESSO2",133,0)
 S XATR(6)=$$UP^XLFSTR($E($G(XATR(6)),1,15))                         ;AD Network Username
"RTN","XUESSO2",134,0)
 S XATR(7)=$TR($E($G(XATR(7)),1,40),"^","%")                         ;SecID
"RTN","XUESSO2",135,0)
 S NEWDUZ=$$ADDU(XATR(4)) ;Put the name in the .01 field first
"RTN","XUESSO2",136,0)
 I +NEWDUZ<1 Q "-1^Create of new user record failed"
"RTN","XUESSO2",137,0)
 S ERRMSG=$$UPDU(.XATR,NEWDUZ) ;Then update the remaining fields
"RTN","XUESSO2",138,0)
 I +ERRMSG<0 D CLEAN(NEWDUZ) Q ERRMSG ;Delete the added user if update fails (incomplete record)
"RTN","XUESSO2",139,0)
 I +NEWDUZ<1 Q "-1^Create or update of user record failed"
"RTN","XUESSO2",140,0)
 Q NEWDUZ  ;Every thing OK
"RTN","XUESSO2",141,0)
 ;
"RTN","XUESSO2",142,0)
SECMATCH(SECID) ;Function. Find match for SECID.
"RTN","XUESSO2",143,0)
 N W,Y,Z
"RTN","XUESSO2",144,0)
 I $G(SECID)="" Q ""
"RTN","XUESSO2",145,0)
 S W=$E(SECID,1,30),Y=0,Z=0
"RTN","XUESSO2",146,0)
 F  D  Q:Y=""
"RTN","XUESSO2",147,0)
 . S Y=$O(^VA(200,"ASECID",$G(SECID),Y))
"RTN","XUESSO2",148,0)
 . I Y>0 D  Q
"RTN","XUESSO2",149,0)
 . . I SECID=$P($G(^VA(200,Y,205)),U,1) S Z=Y,Y=""
"RTN","XUESSO2",150,0)
 Q Z
"RTN","XUESSO2",151,0)
 ;
"RTN","XUESSO2",152,0)
UPNMATCH(ADUPN) ;Function. Find match for ADUPN.
"RTN","XUESSO2",153,0)
 N W,Y,Z
"RTN","XUESSO2",154,0)
 I $G(ADUPN)="" Q ""
"RTN","XUESSO2",155,0)
 S W=$E(ADUPN,1,30),Y=0,Z=0
"RTN","XUESSO2",156,0)
 F  D  Q:Y=""
"RTN","XUESSO2",157,0)
 . S Y=$O(^VA(200,"ADUPN",$G(ADUPN),Y))
"RTN","XUESSO2",158,0)
 . I Y>0 D  Q
"RTN","XUESSO2",159,0)
 . . I ADUPN=$P($G(^VA(200,Y,205)),U,5) S Z=Y,Y=""
"RTN","XUESSO2",160,0)
 Q Z
"RTN","XUESSO2",161,0)
 ;
"RTN","XUESSO2",162,0)
AOIUID(OID,UID) ;Function. Find match for OID+UID cross-reference.
"RTN","XUESSO2",163,0)
 N W,X,Y,Z
"RTN","XUESSO2",164,0)
 I ($G(OID)="")!($G(UID)="") Q ""
"RTN","XUESSO2",165,0)
 S W=$E(OID,1,30),X=$E(UID,1,30),Y=0,Z=0
"RTN","XUESSO2",166,0)
 F  D  Q:Y=""
"RTN","XUESSO2",167,0)
 . S Y=$O(^VA(200,"AOIUID",W,X,Y))
"RTN","XUESSO2",168,0)
 . I Y>0 D  Q
"RTN","XUESSO2",169,0)
 . . I (OID=$P($G(^VA(200,Y,205)),U,3))&(UID=$P($G(^VA(200,Y,205)),U,4)) S Z=Y,Y=""
"RTN","XUESSO2",170,0)
 Q Z
"RTN","XUESSO2",171,0)
 ;
"RTN","XUESSO2",172,0)
ADDU(XUNAME) ;Function. Add a new name to the NPF
"RTN","XUESSO2",173,0)
 N DD,DO,DIC,DA,X,Y,DUZZERO
"RTN","XUESSO2",174,0)
 K ^TMP("DIERR",$J)
"RTN","XUESSO2",175,0)
 S DIC="^VA(200,",DIC(0)="F",X=XUNAME
"RTN","XUESSO2",176,0)
 ; Get a LOCK. Block if can't get.
"RTN","XUESSO2",177,0)
 L +^VA(200,"HL7"):10 Q:'$T "-1^Addition of new users is blocked"
"RTN","XUESSO2",178,0)
 S DUZZERO=DUZ(0),DUZ(0)="@" ;Make sure we can add the entry
"RTN","XUESSO2",179,0)
 D FILE^DICN
"RTN","XUESSO2",180,0)
 S DUZ(0)=DUZZERO ;Restore original FM access
"RTN","XUESSO2",181,0)
 L -^VA(200,"HL7")
"RTN","XUESSO2",182,0)
 Q +Y
"RTN","XUESSO2",183,0)
 ;
"RTN","XUESSO2",184,0)
UPDU(XATR,NEWDUZ) ;Function. Update user in the NPF
"RTN","XUESSO2",185,0)
 N DUZZERO,DIC,ERRMSG,FDR,IEN,XUCODE,XUENTRY
"RTN","XUESSO2",186,0)
 K ^TMP("DIERR",$J)
"RTN","XUESSO2",187,0)
 S DIC(0)="",ERRMSG=""
"RTN","XUESSO2",188,0)
 S IEN=NEWDUZ_","
"RTN","XUESSO2",189,0)
 I ($G(XATR(1))'="")&($P($G(^VA(200,NEWDUZ,205)),U,2)="") S 
FDR(200,IEN,205.2)=$$TITLE^XLFSTR($E($G(XATR(1)),1,50))  ;Add SORG if missing
"RTN","XUESSO2",190,0)
 I ($G(XATR(2))'="")&($P($G(^VA(200,NEWDUZ,205)),U,3)="") S 
FDR(200,IEN,205.3)=$$LOW^XLFSTR($E($G(XATR(2)),1,50))    ;Add OID if missing
"RTN","XUESSO2",191,0)
 I ($G(XATR(3))'="")&($P($G(^VA(200,NEWDUZ,205)),U,4)="") S 
FDR(200,IEN,205.4)=$TR($$LOW^XLFSTR($E($G(XATR(3)),1,40)),"^","%") ;Add UID if missing
"RTN","XUESSO2",192,0)
 I ($G(XATR(6))'="")&($P($G(^VA(200,NEWDUZ,501)),U,1)="") S 
FDR(200,IEN,501.1)=$$UP^XLFSTR($E($G(XATR(6)),1,15))     ;Add NETWORK USERNAME if missing
"RTN","XUESSO2",193,0)
 I ($G(XATR(7))'="")&($P($G(^VA(200,NEWDUZ,205)),U,1)="") S 
FDR(200,IEN,205.1)=$TR($E($G(XATR(7)),1,40),"^","%")     ;Add SecID if missing
"RTN","XUESSO2",194,0)
 I ($G(XATR(8))'="")&($P($G(^VA(200,NEWDUZ,"NPI")),U,1)="") S FDR(200,IEN,41.99)=$G(XATR(8))                         
;Add NPI if missing
"RTN","XUESSO2",195,0)
 I ($G(XATR(9))'="")&($P($G(^VA(200,NEWDUZ,1)),U,9)="") D  Q:ERRMSG'="" ERRMSG                                       
;Add SSN if missing
"RTN","XUESSO2",196,0)
 . S ERRMSG=$$ADDS(.FDR,NEWDUZ,$G(XATR(9)))
"RTN","XUESSO2",197,0)
 . I ERRMSG'="" Q
"RTN","XUESSO2",198,0)
 I ($G(XATR(10))'="")&($P($G(^VA(200,NEWDUZ,205)),U,5)="") S 
FDR(200,IEN,205.5)=$$LOW^XLFSTR($G(XATR(10)))           ;Add ADUPN if missing
"RTN","XUESSO2",199,0)
 I ($G(XATR(11))'="")&($P($G(^VA(200,NEWDUZ,.15)),U,1)="") S 
FDR(200,IEN,.151)=$$LOW^XLFSTR($G(XATR(11)))            ;Add e-mail if missing
"RTN","XUESSO2",200,0)
 I $G(XATR(5))'="" D  Q:ERRMSG'="" ERRMSG  ;Assign Context Option
"RTN","XUESSO2",201,0)
 . S ERRMSG=$$SETCNTXT(NEWDUZ,$G(XATR(5)))
"RTN","XUESSO2",202,0)
 . I ERRMSG'="" Q
"RTN","XUESSO2",203,0)
 ; Apply all the changes
"RTN","XUESSO2",204,0)
 S DUZZERO=DUZ(0),DUZ(0)="@" ;Make sure we can update the entry
"RTN","XUESSO2",205,0)
 I $D(FDR) K IEN D UPDATE^DIE("E","FDR","IEN") ;File all the data
"RTN","XUESSO2",206,0)
 S DUZ(0)=DUZZERO ;Restore original FM access
"RTN","XUESSO2",207,0)
 I $D(^TMP("DIERR",$J)) Q "-1^FileMan error"  ;FileMan Error
"RTN","XUESSO2",208,0)
 I +ERRMSG<1 Q ERRMSG ;Couldn't update user
"RTN","XUESSO2",209,0)
 I +NEWDUZ<1 Q "-1^Update of user record failed"
"RTN","XUESSO2",210,0)
 Q ""
"RTN","XUESSO2",211,0)
 ;
"RTN","XUESSO2",212,0)
ADDS(FDR,NEWDUZ,SSN) ;Function. Add a SSN to the NPF
"RTN","XUESSO2",213,0)
 N IEN,ERRMSG
"RTN","XUESSO2",214,0)
 S IEN=NEWDUZ_",",ERRMSG=""
"RTN","XUESSO2",215,0)
 I '$$SSNCHECK^XUESSO1(SSN) Q "-1^SSN is not valid per SSA criteria"
"RTN","XUESSO2",216,0)
 S FDR(200,IEN,9)=SSN
"RTN","XUESSO2",217,0)
 Q ERRMSG
"RTN","XUESSO2",218,0)
 ;
"RTN","XUESSO2",219,0)
CLEAN(Y) ;Subroutine. Clean up (delete) incomplete record in NPF
"RTN","XUESSO2",220,0)
 ; ZEXCEPT: DA,DIK
"RTN","XUESSO2",221,0)
 N DUZZERO
"RTN","XUESSO2",222,0)
 S DUZZERO=DUZ(0),DUZ(0)="@" ;Make sure we can update the entry
"RTN","XUESSO2",223,0)
 I +Y>0 D
"RTN","XUESSO2",224,0)
 . K DA,DIK S DIK="^VA(200,",DA=+Y D ^DIK
"RTN","XUESSO2",225,0)
 S DUZ(0)=DUZZERO ;Restore original FM access
"RTN","XUESSO2",226,0)
 Q
"RTN","XUESSO2",227,0)
 ;
"RTN","XUESSO2",228,0)
SETCNTXT(NEWDUZ,XAPHRASE) ;Function. Assign Context Option to user Secondary Menu Options
"RTN","XUESSO2",229,0)
 N OPT,XUENTRY,XOPT,XUCONTXT,X
"RTN","XUESSO2",230,0)
 S XUENTRY=$$GETCNTXT(XAPHRASE) I +XUENTRY<0 Q XUENTRY
"RTN","XUESSO2",231,0)
 S XOPT=$P($G(^XWB(8994.5,XUENTRY,0)),U,2)
"RTN","XUESSO2",232,0)
 I XOPT'>0 Q "-1^Context Option must be identified in the REMOTE APPLICATION file"
"RTN","XUESSO2",233,0)
 S XUCONTXT="`"_XOPT
"RTN","XUESSO2",234,0)
 I $$FIND1^DIC(19,"","X",XUCONTXT)'>0 Q "-1^Context Option not in OPTION file"
"RTN","XUESSO2",235,0)
 ;Have to use $D because of screen in 200.03 keeps FIND1^DIC from working.
"RTN","XUESSO2",236,0)
 I '$D(^VA(200,NEWDUZ,203,"B",XOPT)) D
"RTN","XUESSO2",237,0)
 . ; Have to give the user a delegated option
"RTN","XUESSO2",238,0)
 . N XARR S XARR(200.19,"+1,"_NEWDUZ_",",.01)=XUCONTXT
"RTN","XUESSO2",239,0)
 . D UPDATE^DIE("E","XARR")
"RTN","XUESSO2",240,0)
 . ; And now user can give self the context option
"RTN","XUESSO2",241,0)
 . K XARR S XARR(200.03,"+1,"_NEWDUZ_",",.01)=XUCONTXT
"RTN","XUESSO2",242,0)
 . D UPDATE^DIE("E","XARR") ; Give context option as a secondary menu item
"RTN","XUESSO2",243,0)
 . ; But now we have to remove the delegated option
"RTN","XUESSO2",244,0)
 . S OPT=$$FIND1^DIC(200.19,","_NEWDUZ_",","X",XUCONTXT)
"RTN","XUESSO2",245,0)
 . I OPT>0 D
"RTN","XUESSO2",246,0)
 . . K XARR S XARR(200.19,(OPT_","_NEWDUZ_","),.01)="@"
"RTN","XUESSO2",247,0)
 . . D FILE^DIE("E","XARR")
"RTN","XUESSO2",248,0)
 . . Q
"RTN","XUESSO2",249,0)
 . Q
"RTN","XUESSO2",250,0)
 Q ""
"RTN","XUESSO2",251,0)
 ;
"RTN","XUESSO2",252,0)
GETCNTXT(XAPHRASE) ;Function. Identify the REMOTE APPLICATION
"RTN","XUESSO2",253,0)
 N XUCODE,XUENTRY
"RTN","XUESSO2",254,0)
 ;Identify Remote Application with SHA256 hash
"RTN","XUESSO2",255,0)
 S XUCODE=$$SHAHASH^XUSHSH(256,$G(XAPHRASE),"B") ; IA #6189
"RTN","XUESSO2",256,0)
 S XUENTRY=$$FIND1^DIC(8994.5,"","X",XUCODE,"ACODE")
"RTN","XUESSO2",257,0)
 ;If not found, check with old hash and replace with SHA256 hash if found
"RTN","XUESSO2",258,0)
 I XUENTRY'>0 D
"RTN","XUESSO2",259,0)
 . S XUCODE=$$EN^XUSHSH($G(XAPHRASE)) ; IA #10045
"RTN","XUESSO2",260,0)
 . S XUENTRY=$$FIND1^DIC(8994.5,"","X",XUCODE,"ACODE")
"RTN","XUESSO2",261,0)
 . I XUENTRY>0 D
"RTN","XUESSO2",262,0)
 . . S XUCODE=$$SHAHASH^XUSHSH(256,$G(XAPHRASE),"B") ; IA #6189
"RTN","XUESSO2",263,0)
 . . N FDR
"RTN","XUESSO2",264,0)
 . . S FDR(8994.5,XUENTRY_",",.03)=XUCODE
"RTN","XUESSO2",265,0)
 . . D FILE^DIE("E","FDR")
"RTN","XUESSO2",266,0)
 I XUENTRY'>0 Q "-1^Application ID must be registered in the REMOTE APPLICATION file"
"RTN","XUESSO2",267,0)
 Q XUENTRY
"RTN","XUESSO2",268,0)
 ;
"RTN","XUESSO2",269,0)
AUTH() ;Function. Check if calling routine is authorized
"RTN","XUESSO2",270,0)
 ; ^XUESSO2 does not address the security issue of user authentication, so a restriction is placed on the 
calling routine.
"RTN","XUESSO2",271,0)
 ; ZEXCEPT: XTMUNIT,XTU ;set for unit testing
"RTN","XUESSO2",272,0)
 N X,Z
"RTN","XUESSO2",273,0)
 S X=$ST($ST-2,"PLACE"),Z=$P(X,"^",2),X="^"_$P(Z," ")
"RTN","XUESSO2",274,0)
 I $E(X,1,3)="^XU" Q 1          ;Authorized Kernel access
"RTN","XUESSO2",275,0)
 I $D(XTMUNIT)!$G(XTU) Q 1      ;Kernel Unit Testing
"RTN","XUESSO2",276,0)
 Q 0
"RTN","XUESSO2",277,0)
 ;
"RTN","XUESSO3")
0^13^B221983051^B206943521
"RTN","XUESSO3",1,0)
XUESSO3 ;ISD/HGW Enhanced Single Sign-On Utilities ;02/25/16  15:33
"RTN","XUESSO3",2,0)
 ;;8.0;KERNEL;**655,659**;Jul 10, 1995;Build 22
"RTN","XUESSO3",3,0)
 ;Per VA Directive 6402, this routine should not be modified.
"RTN","XUESSO3",4,0)
 ;
"RTN","XUESSO3",5,0)
 Q
"RTN","XUESSO3",6,0)
IAMFU(R,NAME,SSN,DOB,ADUPN,SECID,AUTHCODE) ;RPC. XUS IAM FIND USER - IA #6288
"RTN","XUESSO3",7,0)
 ; The XUSHOWSSN key is required to do lookups using PII (SSN or DoB).
"RTN","XUESSO3",8,0)
 ; Input:  One or more of Name, SSN, DoB, AD UPN, and/or SecID must be provided.
"RTN","XUESSO3",9,0)
 ;           AUTHCODE    = Security Phrase for IAM Provisioning Application
"RTN","XUESSO3",10,0)
 ; Return:   Fail    R(0)="-1^Error Message"
"RTN","XUESSO3",11,0)
 ;           Success R(0)=total number of entries found, from "0" to "n".
"RTN","XUESSO3",12,0)
 ;                   R(1) through R(n)="DUZ^Name^NameComponents^SSN^Dob^AD UPN^SecID"
"RTN","XUESSO3",13,0)
 ;
"RTN","XUESSO3",14,0)
 ; ZEXCEPT: %DT
"RTN","XUESSO3",15,0)
 N X,XARRY,XCOUNT,XI,XJ,XNAME,XRESULT,XSHOWSSN,XTEMP,XUENTRY,XUIAM,Y
"RTN","XUESSO3",16,0)
 K R
"RTN","XUESSO3",17,0)
 I DUZ'>1 S R(0)="-1^Unauthorized access" Q
"RTN","XUESSO3",18,0)
 S XUENTRY=$$GETCNTXT^XUESSO2($G(AUTHCODE)) I +XUENTRY<0 S R(0)=XUENTRY Q
"RTN","XUESSO3",19,0)
 I $P($G(^XWB(8994.5,XUENTRY,0)),U)'="IAM PROVISIONING" S R(0)="-1^Unauthorized access" Q
"RTN","XUESSO3",20,0)
 S XUIAM=1 ;Do not trigger IAM updates
"RTN","XUESSO3",21,0)
 S XSHOWSSN=$$KCHK^XUSRB("XUSHOWSSN")
"RTN","XUESSO3",22,0)
 S XCOUNT=0
"RTN","XUESSO3",23,0)
 ; 1. Search by NAME
"RTN","XUESSO3",24,0)
 I $G(NAME)'="" D
"RTN","XUESSO3",25,0)
 . D FIND^DIC(200,"","@","PC",NAME,"*","B")
"RTN","XUESSO3",26,0)
 . S XI=0 F  S XI=$O(^TMP("DILIST",$J,XI)) Q:'XI  D
"RTN","XUESSO3",27,0)
 . . S XRESULT=$G(^TMP("DILIST",$J,XI,0))
"RTN","XUESSO3",28,0)
 . . D:XRESULT>0 ADDTOLST(.R,.XCOUNT,XSHOWSSN,XRESULT)
"RTN","XUESSO3",29,0)
 . D CLEAN^DILF
"RTN","XUESSO3",30,0)
 . K ^TMP("DILIST",$J)
"RTN","XUESSO3",31,0)
 ; 2. Search by SSN
"RTN","XUESSO3",32,0)
 I ($G(SSN)'="")&($G(XSHOWSSN)=1) D
"RTN","XUESSO3",33,0)
 . S XARRY(9)=SSN
"RTN","XUESSO3",34,0)
 . S XRESULT=$$FINDUSER^XUESSO2(.XARRY)
"RTN","XUESSO3",35,0)
 . I +XRESULT>0 D ADDTOLST(.R,.XCOUNT,XSHOWSSN,XRESULT)
"RTN","XUESSO3",36,0)
 . K XARRY(9)
"RTN","XUESSO3",37,0)
 ; 3. Search by DOB
"RTN","XUESSO3",38,0)
 I ($G(DOB)'="")&($G(XSHOWSSN)=1) D
"RTN","XUESSO3",39,0)
 . S X=DOB,%DT="X" D ^%DT S X=Y,XRESULT=0
"RTN","XUESSO3",40,0)
 . F  D  Q:XRESULT=""
"RTN","XUESSO3",41,0)
 . . S XRESULT=$O(^VA(200,XRESULT)) Q:XRESULT=""
"RTN","XUESSO3",42,0)
 . . I $P($G(^VA(200,XRESULT,1)),U,3)=X D ADDTOLST(.R,.XCOUNT,XSHOWSSN,XRESULT)
"RTN","XUESSO3",43,0)
 ; 4. Search by ADUPN
"RTN","XUESSO3",44,0)
 I $G(ADUPN)'="" D
"RTN","XUESSO3",45,0)
 . S X=$$LOW^XLFSTR(ADUPN),XRESULT=0
"RTN","XUESSO3",46,0)
 . S XRESULT=$$UPNMATCH^XUESSO2(ADUPN)
"RTN","XUESSO3",47,0)
 . I XRESULT>0 D ADDTOLST(.R,.XCOUNT,XSHOWSSN,XRESULT)
"RTN","XUESSO3",48,0)
 ; 5. Search by SECID
"RTN","XUESSO3",49,0)
 I $G(SECID)'="" D
"RTN","XUESSO3",50,0)
 . S XARRY(7)=SECID
"RTN","XUESSO3",51,0)
 . S XRESULT=$$FINDUSER^XUESSO2(.XARRY)
"RTN","XUESSO3",52,0)
 . I +XRESULT>0 D ADDTOLST(.R,.XCOUNT,XSHOWSSN,XRESULT)
"RTN","XUESSO3",53,0)
 . K XARRY(7)
"RTN","XUESSO3",54,0)
 ; 6. Return results
"RTN","XUESSO3",55,0)
 S R(0)=XCOUNT
"RTN","XUESSO3",56,0)
 Q
"RTN","XUESSO3",57,0)
 ;
"RTN","XUESSO3",58,0)
IAMDU(R,DISPDUZ,AUTHCODE) ;RPC. XUS IAM DISPLAY USER - IA #6289
"RTN","XUESSO3",59,0)
 ; Input:  DISPDUZ        = DUZ (IEN) of user to be displayed
"RTN","XUESSO3",60,0)
 ;         AUTHCODE       = Security Phrase for IAM Provisioning Application
"RTN","XUESSO3",61,0)
 ; Return:   Fail    R(0) ="-1^Error Message"
"RTN","XUESSO3",62,0)
 ;           Success R(0) = 1
"RTN","XUESSO3",63,0)
 ;                   R("NAME") = NAME
"RTN","XUESSO3",64,0)
 ;                   R("LASTNAME") = Family Name
"RTN","XUESSO3",65,0)
 ;                   R("FIRSTNAME") = Given Name
"RTN","XUESSO3",66,0)
 ;                   R("MIDDLENAME") = Middle Name
"RTN","XUESSO3",67,0)
 ;                   R("SUFFIX") = Suffix(es)
"RTN","XUESSO3",68,0)
 ;                   R("INITIAL") = INITIAL
"RTN","XUESSO3",69,0)
 ;                   R("TITLE") = TITLE
"RTN","XUESSO3",70,0)
 ;                   R("NICK_NAME") = NICK NAME
"RTN","XUESSO3",71,0)
 ;                   R("SSN") = SSN (<Hidden> if caller does not have XUSHOWSSN key)
"RTN","XUESSO3",72,0)
 ;                   R("DOB") = DOB (<Hidden> if caller does not have XUSHOWSSN key)
"RTN","XUESSO3",73,0)
 ;                   R("DEGREE") = DEGREE
"RTN","XUESSO3",74,0)
 ;                   R("MAIL_CODE") = MAIL CODE
"RTN","XUESSO3",75,0)
 ;                   R("STATUS") = $$ACTIVE^XUSER(DISPDUZ)
"RTN","XUESSO3",76,0)
 ;                   R("DISUSER") = DISUSER
"RTN","XUESSO3",77,0)
 ;                   R("TERMINATION_DATE") = TERMINATION DATE
"RTN","XUESSO3",78,0)
 ;                   R("TERMINATION_REASON") = TERMINATION REASON
"RTN","XUESSO3",79,0)
 ;                   R("PRIMARY_MENU_OPTION") = PRIMARY MENU OPTION
"RTN","XUESSO3",80,0)
 ;                   R("SECONDARY_MENU_OPTION",0) = SECONDARY MENU OPTION (number of entries)
"RTN","XUESSO3",81,0)
 ;                   R("SECONDARY_MENU_OPTION",1) to R("SECONDARY_MENU_OPTION",n) = SECONDARY 
MENU OPTION entries
"RTN","XUESSO3",82,0)
 ;                   R("FILE_MANAGER_ACCESS_CODE") = FILE MANAGER ACCESS CODE
"RTN","XUESSO3",83,0)
 ;                   R("DIVISION",0) = DIVISION (number of entries)
"RTN","XUESSO3",84,0)
 ;                   R("DIVISION",1) to R("DIVISION",n) = DIVISION entries
"RTN","XUESSO3",85,0)
 ;                   R("SERVICE_SECTION") = SERVICE/SECTION
"RTN","XUESSO3",86,0)
 ;                   R("SUBJECT_ALTERNATIVE_NAME") = SUBJECT ALTERNATIVE NAME (PIV CARD)
"RTN","XUESSO3",87,0)
 ;                   R("SECID") = SECID
"RTN","XUESSO3",88,0)
 ;                   R("ORGANIZATION_NAME") = SUBJECT ORGANIZATION
"RTN","XUESSO3",89,0)
 ;                   R("ORGANIZATION_ID") = SUBJECT ORGANIZATION ID
"RTN","XUESSO3",90,0)
 ;                   R("UNIQUE_USER_ID") = UNIQUE USER ID
"RTN","XUESSO3",91,0)
 ;                   R("NETWORK_USER_NAME") = NETWORK USERNAME
"RTN","XUESSO3",92,0)
 ;                   R("AD_UPN") = ADUPN
"RTN","XUESSO3",93,0)
 ;                   R("EMAIL") = EMAIL ADDRESS
"RTN","XUESSO3",94,0)
 ;                   R("GENDER") = SEX (M/F)
"RTN","XUESSO3",95,0)
 ;
"RTN","XUESSO3",96,0)
 N X,XI,XIEN,XJ,XN,XSHOWSSN,XT,XT1,XT205,XT5,XT501,XUENTRY,XUIAM,Y
"RTN","XUESSO3",97,0)
 K R
"RTN","XUESSO3",98,0)
 I DUZ'>1 S R(0)="-1^Unauthorized access" Q
"RTN","XUESSO3",99,0)
 S XUENTRY=$$GETCNTXT^XUESSO2($G(AUTHCODE)) I +XUENTRY<0 S R(0)=XUENTRY Q
"RTN","XUESSO3",100,0)
 I $P($G(^XWB(8994.5,XUENTRY,0)),U)'="IAM PROVISIONING" S R(0)="-1^Unauthorized access" Q
"RTN","XUESSO3",101,0)
 I $G(DUZ("LOA"))<2 S R(0)="-1^Unauthorized access" Q
"RTN","XUESSO3",102,0)
 I $G(DISPDUZ)'>0 S R(0)="-1^User not selected" Q
"RTN","XUESSO3",103,0)
 I $G(^VA(200,DISPDUZ,0))="" S R(0)="-1^User not found" Q
"RTN","XUESSO3",104,0)
 S XUIAM=1 ;Do not trigger IAM updates
"RTN","XUESSO3",105,0)
 S XSHOWSSN=$$KCHK^XUSRB("XUSHOWSSN")
"RTN","XUESSO3",106,0)
 S XT=$G(^VA(200,DISPDUZ,0))
"RTN","XUESSO3",107,0)
 S XT1=$G(^VA(200,DISPDUZ,1))
"RTN","XUESSO3",108,0)
 S XT5=$G(^VA(200,DISPDUZ,5))
"RTN","XUESSO3",109,0)
 S XT205=$G(^VA(200,DISPDUZ,205))
"RTN","XUESSO3",110,0)
 S XT501=$G(^VA(200,DISPDUZ,501))
"RTN","XUESSO3",111,0)
 S R(0)=1
"RTN","XUESSO3",112,0)
 S (XN,R("NAME"))=$P($G(XT),U)
"RTN","XUESSO3",113,0)
 S XIEN=DISPDUZ_","
"RTN","XUESSO3",114,0)
 S X=0 S X=$O(^VA(20,"BB",200,.01,XIEN,X)) ;Get NAME COMPONENTS
"RTN","XUESSO3",115,0)
 S Y="" I +X>0 S Y=$G(^VA(20,X,1))
"RTN","XUESSO3",116,0)
 S R("LASTNAME")=$P(Y,U)
"RTN","XUESSO3",117,0)
 S R("FIRSTNAME")=$P(Y,U,2)
"RTN","XUESSO3",118,0)
 S R("MIDDLENAME")=$P(Y,U,3)
"RTN","XUESSO3",119,0)
 S R("SUFFIX")=$P(Y,U,4)
"RTN","XUESSO3",120,0)
 S R("INITIAL")=$P($G(XT),U,2)
"RTN","XUESSO3",121,0)
 S R("TITLE")="" S X=$P($G(XT),U,9)
"RTN","XUESSO3",122,0)
 I $G(X)>0 S R("TITLE")=$P($G(^DIC(3.1,X,0)),U)
"RTN","XUESSO3",123,0)
 S R("NICK_NAME")=$P($G(^VA(200,DISPDUZ,.1)),U,4)
"RTN","XUESSO3",124,0)
 S R("SSN")="<Hidden>" I $G(XSHOWSSN)=1 S R("SSN")=$P($G(XT1),U,9)
"RTN","XUESSO3",125,0)
 S R("DOB")="<Hidden>" I $G(XSHOWSSN)=1 S 
R("DOB")=$TR($$FMTE^XLFDT($P($G(XT1),U,3),"5DZ"),"/","")
"RTN","XUESSO3",126,0)
 S R("DEGREE")=$P($G(^VA(200,DISPDUZ,3.1)),U,6)
"RTN","XUESSO3",127,0)
 S R("MAIL_CODE")=$P($G(XT5),U,2)
"RTN","XUESSO3",128,0)
 S R("STATUS")=$$ACTIVE^XUSER(DISPDUZ) ;Supported IA #2343
"RTN","XUESSO3",129,0)
 S X=$P($G(R("STATUS")),U,3) I X'="" D
"RTN","XUESSO3",130,0)
 . S X=$TR($$FMTE^XLFDT(X,"5DZ"),"/","")
"RTN","XUESSO3",131,0)
 . S $P(R("STATUS"),U,3)=X
"RTN","XUESSO3",132,0)
 S R("DISUSER")=$P($G(XT),U,7)
"RTN","XUESSO3",133,0)
 S R("TERMINATION_DATE")=$TR($$FMTE^XLFDT($P($G(XT),U,11),"5DZ"),"/","")
"RTN","XUESSO3",134,0)
 S R("TERMINATION_REASON")=$P($G(XT),U,13)
"RTN","XUESSO3",135,0)
 S R("PRIMARY_MENU_OPTION")=$P($G(^VA(200,DISPDUZ,201)),U)
"RTN","XUESSO3",136,0)
 I $G(R("PRIMARY_MENU_OPTION"))>0 S 
R("PRIMARY_MENU_OPTION")=$P($G(^DIC(19,R("PRIMARY_MENU_OPTION"),0)),U)
"RTN","XUESSO3",137,0)
 S (XI,XJ)=0
"RTN","XUESSO3",138,0)
 I $G(^VA(200,DISPDUZ,203,0))'="" F  D  Q:+XI'>0
"RTN","XUESSO3",139,0)
 . S XI=$O(^VA(200,DISPDUZ,203,XI)) Q:+XI'>0
"RTN","XUESSO3",140,0)
 . S XJ=XJ+1,R("SECONDARY_MENU_OPTION",XJ)=$P($G(^VA(200,DISPDUZ,203,XI,0)),U)
"RTN","XUESSO3",141,0)
 . I $G(R("SECONDARY_MENU_OPTION",XJ))>0 S 
R("SECONDARY_MENU_OPTION",XJ)=$P($G(^DIC(19,R("SECONDARY_MENU_OPTION",XJ),0)),U)
"RTN","XUESSO3",142,0)
 S R("SECONDARY_MENU_OPTION",0)=XJ ;number of entries
"RTN","XUESSO3",143,0)
 S R("FILE_MANAGER_ACCESS_CODE")=$P($G(XT),U,4)
"RTN","XUESSO3",144,0)
 S (XI,XJ)=0
"RTN","XUESSO3",145,0)
 I $G(^VA(200,DISPDUZ,2,0))'="" F  D  Q:+XI'>0
"RTN","XUESSO3",146,0)
 . S XI=$O(^VA(200,DISPDUZ,2,XI)) Q:+XI'>0
"RTN","XUESSO3",147,0)
 . S XJ=XJ+1,R("DIVISION",XJ)=$P($G(^VA(200,DISPDUZ,2,XI,0)),U)
"RTN","XUESSO3",148,0)
 . I $G(R("DIVISION",XJ))>0 S R("DIVISION",XJ)=$P($G(^DIC(4,R("DIVISION",XJ),99)),U)
"RTN","XUESSO3",149,0)
 S R("DIVISION",0)=XJ ;number of entries
"RTN","XUESSO3",150,0)
 S R("SERVICE_SECTION")=$P($G(XT5),U,1)
"RTN","XUESSO3",151,0)
 I $G(R("SERVICE_SECTION"))>0 S R("SERVICE_SECTION")=$P($G(^DIC(49,R("SERVICE_SECTION"),0)),U)
"RTN","XUESSO3",152,0)
 S R("SUBJECT_ALTERNATIVE_NAME")=$P($G(XT501),U,2)
"RTN","XUESSO3",153,0)
 S R("SECID")=$TR($P($G(XT205),U),"%","^")
"RTN","XUESSO3",154,0)
 S R("ORGANIZATION_NAME")=$P($G(XT205),U,2)
"RTN","XUESSO3",155,0)
 S R("ORGANIZATION_ID")=$P($G(XT205),U,3)
"RTN","XUESSO3",156,0)
 S R("UNIQUE_USER_ID")=$P($G(XT205),U,4)
"RTN","XUESSO3",157,0)
 S R("NETWORK_USER_NAME")=$P($G(XT501),U)
"RTN","XUESSO3",158,0)
 S R("AD_UPN")=$P($G(XT205),U,5)
"RTN","XUESSO3",159,0)
 S R("EMAIL")=$P($G(^VA(200,DISPDUZ,.15)),U)
"RTN","XUESSO3",160,0)
 S R("GENDER")=$P($G(XT1),U,2)
"RTN","XUESSO3",161,0)
 Q
"RTN","XUESSO3",162,0)
 ;
"RTN","XUESSO3",163,0)
IAMAU(R,NAME,SECID,EMAIL,ADUPN,SSN,DOB,STATION,AUTHCODE) ;RPC. XUS IAM ADD USER - IA 
#6290
"RTN","XUESSO3",164,0)
 ; The XUSPF200 security key is required to add a user without an SSN (file #200 special privileges).
"RTN","XUESSO3",165,0)
 ; Input:  NAME      = SubjectID to be used in SAML Token
"RTN","XUESSO3",166,0)
 ;         SECID     = UniqueUserID to be used in SSOi or SSOe SAML Token
"RTN","XUESSO3",167,0)
 ;         EMAIL     = User's e-mail address
"RTN","XUESSO3",168,0)
 ;         ADUPN     = Active Directory User Principle Name
"RTN","XUESSO3",169,0)
 ;         SSN       = User's Social Security Number or Taxpayer Identification Number
"RTN","XUESSO3",170,0)
 ;         DOB       = User's Date of Birth
"RTN","XUESSO3",171,0)
 ;         STATION   = NEW PERSON file (#200) DIVISION
"RTN","XUESSO3",172,0)
 ;         AUTHCODE  = (Required) Security Phrase for IAM Provisioning Application
"RTN","XUESSO3",173,0)
 ; Return: Fail    R(0)               = "-1^Number of Errors"
"RTN","XUESSO3",174,0)
 ;                 R(1) through R(n)  = "Error Message"
"RTN","XUESSO3",175,0)
 ;         Success R(0)               = "DUZ^STATION"
"RTN","XUESSO3",176,0)
 ;
"RTN","XUESSO3",177,0)
 ; ZEXCEPT: %DT,DA,DIERR,DIK ;FileMan special variables
"RTN","XUESSO3",178,0)
 N DIC,DUZZERO,ERRMSG,FDR,IEN,NEWDUZ,X,XARRAY,XDIV,XUENTRY,XUIAM,Y
"RTN","XUESSO3",179,0)
 K R
"RTN","XUESSO3",180,0)
 S R(0)=0
"RTN","XUESSO3",181,0)
 I DUZ'>1 D EDITERR(.R,"Unauthorized access") Q
"RTN","XUESSO3",182,0)
 I +$$ACTIVE^XUSER(DUZ)=0 D EDITERR(.R,"Unauthorized access") Q
"RTN","XUESSO3",183,0)
 I $G(DUZ("LOA"))<2 D EDITERR(.R,"Unauthorized access") Q
"RTN","XUESSO3",184,0)
 S XUIAM=1 ;Do not trigger IAM updates
"RTN","XUESSO3",185,0)
 I ($G(SSN)'>1)&('$$KCHK^XUSRB("XUSPF200")) D EDITERR(.R,"Need XUSPF200 key if no SSN") Q
"RTN","XUESSO3",186,0)
 S XUENTRY=$$GETCNTXT^XUESSO2($G(AUTHCODE)) I +XUENTRY<0 D EDITERR(.R,XUENTRY) Q
"RTN","XUESSO3",187,0)
 I $P($G(^XWB(8994.5,XUENTRY,0)),U)'="IAM PROVISIONING" D EDITERR(.R,"Unauthorized access") Q
"RTN","XUESSO3",188,0)
 I $G(NAME)="" D EDITERR(.R,"Missing SubjectID") Q
"RTN","XUESSO3",189,0)
 I $G(SECID)="" D EDITERR(.R,"Missing SecID") Q
"RTN","XUESSO3",190,0)
 S Y=$$SECMATCH^XUESSO2(SECID) I Y>0 D EDITERR(.R,"User with given SecID already exists") Q
"RTN","XUESSO3",191,0)
 I $G(SSN)>1 S Y=+$O(^VA(200,"SSN",SSN,0))
"RTN","XUESSO3",192,0)
 I Y>0 D EDITERR(.R,"User with given SSN already exists") Q
"RTN","XUESSO3",193,0)
 I ($G(SSN)>1)&('$$SSNCHECK^XUESSO1($G(SSN))) D EDITERR(.R,"Invalid SSN") Q
"RTN","XUESSO3",194,0)
 I $G(DOB)'="" D  Q:Y=-1
"RTN","XUESSO3",195,0)
 . S X=DOB S %DT="X" D ^%DT I Y=-1 D EDITERR(.R,"Invalid DOB") Q
"RTN","XUESSO3",196,0)
 . S DOB=$G(Y)
"RTN","XUESSO3",197,0)
 I $G(STATION)'="" D  Q:Y=""
"RTN","XUESSO3",198,0)
 . S Y="" S Y=$O(^DIC(4,"D",$G(STATION),Y))
"RTN","XUESSO3",199,0)
 . I Y="" D EDITERR(.R,"-1^Invalid STATION") Q
"RTN","XUESSO3",200,0)
 . S XDIV=$P($G(^DIC(4,Y,0)),U,1)
"RTN","XUESSO3",201,0)
 S XARRAY(1)=$P($G(^XTV(8989.3,1,200)),U,2)
"RTN","XUESSO3",202,0)
 S XARRAY(2)=$P($G(^XTV(8989.3,1,200)),U,3)
"RTN","XUESSO3",203,0)
 S XARRAY(3)=SECID
"RTN","XUESSO3",204,0)
 S XARRAY(4)=NAME
"RTN","XUESSO3",205,0)
 S XARRAY(7)=SECID
"RTN","XUESSO3",206,0)
 S XARRAY(9)=$G(SSN)
"RTN","XUESSO3",207,0)
 S Y=$$ADDUSER^XUESSO2(.XARRAY) ;Add the user
"RTN","XUESSO3",208,0)
 I +Y<0 D EDITERR(.R,Y) Q
"RTN","XUESSO3",209,0)
 S NEWDUZ=Y
"RTN","XUESSO3",210,0)
 ;Use FM calls to edit the user with the remaining information
"RTN","XUESSO3",211,0)
 K ^TMP("DIERR",$J)
"RTN","XUESSO3",212,0)
 S DIC(0)="",ERRMSG=""
"RTN","XUESSO3",213,0)
 S IEN=NEWDUZ_","
"RTN","XUESSO3",214,0)
 I $G(EMAIL)'="" S FDR(200,IEN,.151)=$$LOW^XLFSTR(EMAIL)
"RTN","XUESSO3",215,0)
 I $G(ADUPN)'="" S FDR(200,IEN,205.5)=$$LOW^XLFSTR(ADUPN)
"RTN","XUESSO3",216,0)
 I $G(DOB)'="" S FDR(200,IEN,5)=DOB
"RTN","XUESSO3",217,0)
 I $G(XDIV)'="" S FDR(200.02,"+3,"_IEN,.01)=XDIV
"RTN","XUESSO3",218,0)
 ; Apply all the changes: File valid values and reject invalid values.
"RTN","XUESSO3",219,0)
 S DUZZERO=DUZ(0),DUZ(0)="@"
"RTN","XUESSO3",220,0)
 I $D(FDR) K IEN D UPDATE^DIE("E","FDR","IEN") ;File all the data
"RTN","XUESSO3",221,0)
 S DUZ(0)=DUZZERO ;Restore original FM access
"RTN","XUESSO3",222,0)
 I $D(DIERR) D
"RTN","XUESSO3",223,0)
 . S Y=0
"RTN","XUESSO3",224,0)
 . F  D  Q:+Y'>0
"RTN","XUESSO3",225,0)
 . . S Y=$O(^TMP("DIERR",$J,Y)) I +Y>0 W !,$G(^TMP("DIERR",$J,Y,"TEXT",1))
"RTN","XUESSO3",226,0)
 . . I +Y>0 D EDITERR(.R,$G(^TMP("DIERR",$J,Y,"TEXT",1))) ;FileMan Error
"RTN","XUESSO3",227,0)
 . K DA,DIK S DIK="^VA(200,",DA=NEWDUZ D ^DIK ;Rollback add if all fields could not be filed
"RTN","XUESSO3",228,0)
 I +$G(R(0))'=-1 S R(0)=NEWDUZ_U_STATION
"RTN","XUESSO3",229,0)
 Q
"RTN","XUESSO3",230,0)
 ;
"RTN","XUESSO3",231,0)
IAMEU(R,INARRY,AUTHCODE) ;RPC. XUS IAM EDIT USER - IA #6291
"RTN","XUESSO3",232,0)
 ; The XUSHOWSSN security key is required to allow edit of PII (SSN and DoB).
"RTN","XUESSO3",233,0)
 ; Input:  INARRY("SECID")            = SecID - Used to identify entry to be edited
"RTN","XUESSO3",234,0)
 ;         INARRAY("LASTNAME")        = User NAME is "LASTNAME,FIRSTNAME MIDDLENAME SUFFIX"
"RTN","XUESSO3",235,0)
 ;         INARRAY("FIRSTNAME")
"RTN","XUESSO3",236,0)
 ;         INARRAY("MIDDLENAME")
"RTN","XUESSO3",237,0)
 ;         INARRAY("SUFFIX")
"RTN","XUESSO3",238,0)
 ;         INARRY("ORGANIZATION_NAME")= SUBJECT ORGANIZATION
"RTN","XUESSO3",239,0)
 ;         INARRY("ORGANIZATION_ID")  = SUBJECT ORGANIZATION ID
"RTN","XUESSO3",240,0)
 ;         INARRY("EMAIL")            = EMAIL ADDRESS
"RTN","XUESSO3",241,0)
 ;         INARRY("AD_UPN")           = ADUPN
"RTN","XUESSO3",242,0)
 ;         INARRY("SSN")              = SSN
"RTN","XUESSO3",243,0)
 ;         INARRY("DOB")              = DOB (Date of Birth)
"RTN","XUESSO3",244,0)
 ;         AUTHCODE                   = Security Phrase for IAM Provisioning Application
"RTN","XUESSO3",245,0)
 ; Return: Fail    R(0)               = "-1^Number of Errors"
"RTN","XUESSO3",246,0)
 ;                 R(1) through R(n)  = "Error Message"
"RTN","XUESSO3",247,0)
 ;         Success R(0)               = DUZ of NEW PERSON file entry that was edited
"RTN","XUESSO3",248,0)
 ;
"RTN","XUESSO3",249,0)
 ; ZEXCEPT: %DT,DIERR ;FileMan special variables
"RTN","XUESSO3",250,0)
 N DUZZERO,FDR,IEN,X,XARRAY,XDUZ,XSHOWSSN,XUENTRY,XUIAM,XUN,XUNAME,XUNEWN,XUOLDN,Y
"RTN","XUESSO3",251,0)
 K R
"RTN","XUESSO3",252,0)
 S R(0)=0
"RTN","XUESSO3",253,0)
 S XUIAM=1 ;Do not trigger IAM updates
"RTN","XUESSO3",254,0)
 I DUZ'>1 D EDITERR(.R,"Unauthorized access") Q
"RTN","XUESSO3",255,0)
 I +$$ACTIVE^XUSER(DUZ)=0 D EDITERR(.R,"Unauthorized access") Q
"RTN","XUESSO3",256,0)
 S XUENTRY=$$GETCNTXT^XUESSO2($G(AUTHCODE)) I +XUENTRY<0 D EDITERR(.R,$P(XUENTRY,U,2)) Q
"RTN","XUESSO3",257,0)
 I $P($G(^XWB(8994.5,XUENTRY,0)),U)'="IAM PROVISIONING" D EDITERR(.R,"Unauthorized access") Q
"RTN","XUESSO3",258,0)
 I $G(DUZ("LOA"))<2 D EDITERR(.R,"Unauthorized access") Q
"RTN","XUESSO3",259,0)
 I $G(INARRY("SECID"))="" D EDITERR(.R,"User not identified by SecID") Q
"RTN","XUESSO3",260,0)
 S XARRAY(7)=INARRY("SECID")
"RTN","XUESSO3",261,0)
 S XDUZ=$$SECMATCH^XUESSO2(XARRAY(7)) I XDUZ'>0 D EDITERR(.R,"User not found") Q
"RTN","XUESSO3",262,0)
 I $S($P(^VA(200,XDUZ,0),U,11):$P(^VA(200,XDUZ,0),U,11)<DT,1:0) D EDITERR(.R,"Not allowed to edit 
terminated user") Q
"RTN","XUESSO3",263,0)
 S XSHOWSSN=$$KCHK^XUSRB("XUSHOWSSN")
"RTN","XUESSO3",264,0)
 I ($G(INARRY("SSN")))&('XSHOWSSN) D EDITERR(.R,"XUSHOWSSN Security Key is required to edit SSN")
"RTN","XUESSO3",265,0)
 I ($G(INARRY("DOB")))&('XSHOWSSN) D EDITERR(.R,"XUSHOWSSN Security Key is required to edit 
DOB")
"RTN","XUESSO3",266,0)
 ;Use FM calls to edit the user with the remaining information
"RTN","XUESSO3",267,0)
 K ^TMP("DIERR",$J)
"RTN","XUESSO3",268,0)
 S IEN=XDUZ_","
"RTN","XUESSO3",269,0)
 S XUN("FILE")=200,XUN("IENS")=IEN,XUN("FIELD")=.01
"RTN","XUESSO3",270,0)
 S XUOLDN=$$NAMEFMT^XLFNAME(.XUN,"F","CS")
"RTN","XUESSO3",271,0)
 K XUN S XUN=XUOLDN
"RTN","XUESSO3",272,0)
 D NAMECOMP^XLFNAME(.XUN)
"RTN","XUESSO3",273,0)
 I $D(INARRY("LASTNAME")) S XUN("FAMILY")=$G(INARRY("LASTNAME"))
"RTN","XUESSO3",274,0)
 I $D(INARRY("FIRSTNAME")) S XUN("GIVEN")=$G(INARRY("FIRSTNAME"))
"RTN","XUESSO3",275,0)
 I $D(INARRY("MIDDLENAME")) S XUN("MIDDLE")=$G(INARRY("MIDDLENAME"))
"RTN","XUESSO3",276,0)
 I $D(INARRY("SUFFIX")) S XUN("SUFFIX")=$G(INARRY("SUFFIX"))
"RTN","XUESSO3",277,0)
 S XUNEWN=$$NAMEFMT^XLFNAME(.XUN,"F","CS")
"RTN","XUESSO3",278,0)
 I XUNEWN'=XUOLDN S FDR(200,IEN,.01)=XUNEWN ;set NAME if changed
"RTN","XUESSO3",279,0)
 I $G(INARRY("ORGANIZATION_NAME"))'="" D
"RTN","XUESSO3",280,0)
 . S X=$$TITLE^XLFSTR($E(INARRY("ORGANIZATION_NAME"),1,50))
"RTN","XUESSO3",281,0)
 . I X'=$P($G(^VA(200,XDUZ,205)),U,2) S FDR(200,IEN,205.2)=X ;set SUBJECT ORGANIZATION if changed
"RTN","XUESSO3",282,0)
 I $G(INARRY("ORGANIZATION_ID"))'="" D
"RTN","XUESSO3",283,0)
 . S X=$$LOW^XLFSTR($E(INARRY("ORGANIZATION_ID"),1,50))
"RTN","XUESSO3",284,0)
 . I X'=$P($G(^VA(200,XDUZ,205)),U,3) S FDR(200,IEN,205.3)=X ;set SUBJECT ORGANIZATION ID if 
changed
"RTN","XUESSO3",285,0)
 I $G(INARRY("EMAIL"))'="" D
"RTN","XUESSO3",286,0)
 . S X=$$LOW^XLFSTR(INARRY("EMAIL"))
"RTN","XUESSO3",287,0)
 . I X'=$P($G(^VA(200,XDUZ,.15)),U) S FDR(200,IEN,.151)=X ;set EMAIL ADDRESS if changed
"RTN","XUESSO3",288,0)
 I $G(INARRY("AD_UPN"))'="" D
"RTN","XUESSO3",289,0)
 . S X=$$LOW^XLFSTR($E(INARRY("AD_UPN"),1,50))
"RTN","XUESSO3",290,0)
 . I X'=$P($G(^VA(200,XDUZ,205)),U,5) S FDR(200,IEN,205.5)=X ;edit ADUPN if changed
"RTN","XUESSO3",291,0)
 I ($G(INARRY("SSN"))'="")&(XSHOWSSN) D
"RTN","XUESSO3",292,0)
 . S X=+$O(^VA(200,"SSN",INARRY("SSN"),0)) ;Search for existing user with this SSN
"RTN","XUESSO3",293,0)
 . I +X>0 D  ;SSN found
"RTN","XUESSO3",294,0)
 . . I +X'=XDUZ D  ;SSN assigned to another user
"RTN","XUESSO3",295,0)
 . . . D EDITERR(.R,"This SSN is assigned to another user")
"RTN","XUESSO3",296,0)
 . . ; else SSN is assigned to this user, so no need to change SSN
"RTN","XUESSO3",297,0)
 . E  D  ;SSN not found
"RTN","XUESSO3",298,0)
 . . I $$SSNCHECK^XUESSO1(INARRY("SSN")) D  ;validate SSN
"RTN","XUESSO3",299,0)
 . . . S FDR(200,IEN,9)=INARRY("SSN") ;edit SSN if valid
"RTN","XUESSO3",300,0)
 . . E  D  ;error if SSN not valid
"RTN","XUESSO3",301,0)
 . . . D EDITERR(.R,"Not a valid SSN")
"RTN","XUESSO3",302,0)
 I ($G(INARRY("DOB"))'="")&(XSHOWSSN) D
"RTN","XUESSO3",303,0)
 . S X=INARRY("DOB") S %DT="X" D ^%DT
"RTN","XUESSO3",304,0)
 . I Y>1 D
"RTN","XUESSO3",305,0)
 . . I Y'=$P($G(^VA(200,XDUZ,1)),U,3) S FDR(200,IEN,5)=Y ;edit DOB if changed
"RTN","XUESSO3",306,0)
 . E  D  ;error if DOB not valid
"RTN","XUESSO3",307,0)
 . . D EDITERR(.R,"Not a valid DOB")
"RTN","XUESSO3",308,0)
 ; Apply all the changes: File valid values and reject invalid values.
"RTN","XUESSO3",309,0)
 S DUZZERO=DUZ(0),DUZ(0)="@"
"RTN","XUESSO3",310,0)
 I $D(FDR) D FILE^DIE("E","FDR") ;File all the data
"RTN","XUESSO3",311,0)
 S DUZ(0)=DUZZERO ;Restore original FM access
"RTN","XUESSO3",312,0)
 I $D(DIERR) D
"RTN","XUESSO3",313,0)
 . S Y=0
"RTN","XUESSO3",314,0)
 . F  D  Q:+Y'>0
"RTN","XUESSO3",315,0)
 . . S Y=$O(^TMP("DIERR",$J,Y))
"RTN","XUESSO3",316,0)
 . . I +Y>0 D EDITERR(.R,$G(^TMP("DIERR",$J,Y,"TEXT",1))) ;FileMan Error
"RTN","XUESSO3",317,0)
 E  I +$G(R(0))'=-1 D
"RTN","XUESSO3",318,0)
 . S R(0)=XDUZ
"RTN","XUESSO3",319,0)
 Q
"RTN","XUESSO3",320,0)
 ;
"RTN","XUESSO3",321,0)
IAMTU(R,SECID,TERMDATE,TERMRESN,AUTHCODE) ;RPC. XUS IAM TERMINATE USER - IA #6292
"RTN","XUESSO3",322,0)
 ; Input:  SECID                     = SECID - Used to identify entry to be edited
"RTN","XUESSO3",323,0)
 ;         TERMDATE                  = TERMINATION DATE
"RTN","XUESSO3",324,0)
 ;         TERMRESN                  = Termination Reason
"RTN","XUESSO3",325,0)
 ;         AUTHCODE                  = Security Phrase for IAM Provisioning Application
"RTN","XUESSO3",326,0)
 ; Return: Fail    R(0)              = "-1^Number of Errors"
"RTN","XUESSO3",327,0)
 ;                 R(1) through R(n) = "Error Message"
"RTN","XUESSO3",328,0)
 ;         Success R(0)              = DUZ
"RTN","XUESSO3",329,0)
 ;
"RTN","XUESSO3",330,0)
 ; ZEXCEPT: %DT,DIERR ;FileMan special variables
"RTN","XUESSO3",331,0)
 N DUZZERO,FDR,IEN,INARRY,X,XARRAY,XDUZ,XUENTRY,XUIAM,Y
"RTN","XUESSO3",332,0)
 K R
"RTN","XUESSO3",333,0)
 S R(0)=0
"RTN","XUESSO3",334,0)
 S XUIAM=1 ;Do not trigger IAM updates
"RTN","XUESSO3",335,0)
 I DUZ'>1 D EDITERR(.R,"Unauthorized access") Q
"RTN","XUESSO3",336,0)
 I +$$ACTIVE^XUSER(DUZ)=0 D EDITERR(.R,"Unauthorized access") Q
"RTN","XUESSO3",337,0)
 S XUENTRY=$$GETCNTXT^XUESSO2($G(AUTHCODE)) I +XUENTRY<0 D EDITERR(.R,$P(XUENTRY,U,2)) Q
"RTN","XUESSO3",338,0)
 I $P($G(^XWB(8994.5,XUENTRY,0)),U)'="IAM PROVISIONING" D EDITERR(.R,"Unauthorized access") Q
"RTN","XUESSO3",339,0)
 I $G(SECID)="" D EDITERR(.R,"User not identified by SecID") Q
"RTN","XUESSO3",340,0)
 I $G(TERMDATE)="" D EDITERR(.R,"Missing Termination Date") Q
"RTN","XUESSO3",341,0)
 I $G(TERMRESN)="" D EDITERR(.R,"Missing Termination Reason") Q
"RTN","XUESSO3",342,0)
 S XARRAY(7)=SECID ;SecID
"RTN","XUESSO3",343,0)
 S XDUZ=$$FINDUSER^XUESSO2(.XARRAY) ;Find user to be terminated
"RTN","XUESSO3",344,0)
 I +XDUZ'>1 D EDITERR(.R,"User not found") Q
"RTN","XUESSO3",345,0)
 ;Use FM calls to edit the user
"RTN","XUESSO3",346,0)
 K ^TMP("DIERR",$J)
"RTN","XUESSO3",347,0)
 S IEN=XDUZ_","
"RTN","XUESSO3",348,0)
 S FDR(200,IEN,9.2)=TERMDATE ;set Termination Date
"RTN","XUESSO3",349,0)
 S FDR(200,IEN,9.4)=$E(TERMRESN,1,45) ;set Termination Reason
"RTN","XUESSO3",350,0)
 ; Apply the changes.
"RTN","XUESSO3",351,0)
 S DUZZERO=DUZ(0),DUZ(0)="@"
"RTN","XUESSO3",352,0)
 I $D(FDR) D FILE^DIE("E","FDR") ;File all the data
"RTN","XUESSO3",353,0)
 S DUZ(0)=DUZZERO ;Restore original FM access
"RTN","XUESSO3",354,0)
 I $D(DIERR) D
"RTN","XUESSO3",355,0)
 . S Y=0
"RTN","XUESSO3",356,0)
 . F  D  Q:+Y'>0
"RTN","XUESSO3",357,0)
 . . S Y=$O(^TMP("DIERR",$J,Y))
"RTN","XUESSO3",358,0)
 . . I +Y>0 D EDITERR(.R,$G(^TMP("DIERR",$J,Y,"TEXT",1))) ;FileMan Error
"RTN","XUESSO3",359,0)
 E  I +$G(R(0))'=-1 D
"RTN","XUESSO3",360,0)
 . S R(0)=XDUZ
"RTN","XUESSO3",361,0)
 Q
"RTN","XUESSO3",362,0)
 ;
"RTN","XUESSO3",363,0)
IAMRU(R,SECID,AUTHCODE) ;RPC. XUS IAM REACTIVATE USER - IA #6293
"RTN","XUESSO3",364,0)
 ; Input:  SECID                     = SECID - Used to identify entry to be edited
"RTN","XUESSO3",365,0)
 ;         AUTHCODE                  = Security Phrase for IAM Provisioning Application
"RTN","XUESSO3",366,0)
 ; Return: Fail    R(0)              = "-1^Number of Errors"
"RTN","XUESSO3",367,0)
 ;                 R(1) through R(n) = "Error Message"
"RTN","XUESSO3",368,0)
 ;         Success R(0)              = 1
"RTN","XUESSO3",369,0)
 ;
"RTN","XUESSO3",370,0)
 ; ZEXCEPT: DIERR ;FileMan special variables
"RTN","XUESSO3",371,0)
 N DUZZERO,FDR,IEN,INARRY,X,XARRAY,XDUZ,XUENTRY,XUIAM,Y
"RTN","XUESSO3",372,0)
 K R
"RTN","XUESSO3",373,0)
 S R(0)=0
"RTN","XUESSO3",374,0)
 S XUIAM=1 ;Do not trigger IAM updates
"RTN","XUESSO3",375,0)
 I DUZ'>1 D EDITERR(.R,"Unauthorized access") Q
"RTN","XUESSO3",376,0)
 I +$$ACTIVE^XUSER(DUZ)=0 D EDITERR(.R,"Unauthorized access") Q
"RTN","XUESSO3",377,0)
 S XUENTRY=$$GETCNTXT^XUESSO2($G(AUTHCODE)) I +XUENTRY<0 D EDITERR(.R,$P(XUENTRY,U,2)) Q
"RTN","XUESSO3",378,0)
 I $P($G(^XWB(8994.5,XUENTRY,0)),U)'="IAM PROVISIONING" D EDITERR(.R,"Unauthorized access") Q
"RTN","XUESSO3",379,0)
 I $G(SECID)="" D EDITERR(.R,"User not identified by SecID") Q
"RTN","XUESSO3",380,0)
 S XARRAY(7)=SECID ;SecID
"RTN","XUESSO3",381,0)
 S XDUZ=$$FINDUSER^XUESSO2(.XARRAY) ;Find user to be reactivated
"RTN","XUESSO3",382,0)
 I +XDUZ'>1 D EDITERR(.R,"User not found") Q
"RTN","XUESSO3",383,0)
 K ^TMP("DIERR",$J)
"RTN","XUESSO3",384,0)
 S IEN=XDUZ_","
"RTN","XUESSO3",385,0)
 S FDR(200,IEN,9.2)="" ;set Termination Date
"RTN","XUESSO3",386,0)
 ; Apply the changes.
"RTN","XUESSO3",387,0)
 S DUZZERO=DUZ(0),DUZ(0)="@"
"RTN","XUESSO3",388,0)
 I $D(FDR) D FILE^DIE("E","FDR") ;File all the data
"RTN","XUESSO3",389,0)
 S DUZ(0)=DUZZERO ;Restore original FM access
"RTN","XUESSO3",390,0)
 I $D(DIERR) D
"RTN","XUESSO3",391,0)
 . S Y=0
"RTN","XUESSO3",392,0)
 . F  D  Q:+Y'>0
"RTN","XUESSO3",393,0)
 . . S Y=$O(^TMP("DIERR",$J,Y))
"RTN","XUESSO3",394,0)
 . . I +Y>0 D EDITERR(.R,$G(^TMP("DIERR",$J,Y,"TEXT",1))) ;FileMan Error
"RTN","XUESSO3",395,0)
 E  I +$G(R(0))'=-1 D
"RTN","XUESSO3",396,0)
 . S R(0)=XDUZ
"RTN","XUESSO3",397,0)
 Q
"RTN","XUESSO3",398,0)
 ;
"RTN","XUESSO3",399,0)
ADDTOLST(XR,XCOUNT,XSHOWSSN,XRESULT) ;Intrinsic Subroutine. Add user to list.
"RTN","XUESSO3",400,0)
 N XFLAG,XI,XODOB,XONME,XONMEC,XOSEC,XOSSN,XOUPN
"RTN","XUESSO3",401,0)
 S XFLAG=0
"RTN","XUESSO3",402,0)
 F XI=1:1:XCOUNT D
"RTN","XUESSO3",403,0)
 . I XRESULT=$P($G(XR(XI)),U) S XFLAG=1
"RTN","XUESSO3",404,0)
 I XFLAG=0 D
"RTN","XUESSO3",405,0)
 . S XCOUNT=XCOUNT+1
"RTN","XUESSO3",406,0)
 . S XONME=$P($G(^VA(200,XRESULT,0)),U)
"RTN","XUESSO3",407,0)
 . S XONMEC=$$NAMECOMP(XRESULT)
"RTN","XUESSO3",408,0)
 . S XOSSN="<Hidden>" I $G(XSHOWSSN)=1 S XOSSN=$P($G(^VA(200,XRESULT,1)),U,9)
"RTN","XUESSO3",409,0)
 . S XODOB="<Hidden>" I $G(XSHOWSSN)=1 S 
XODOB=$TR($$FMTE^XLFDT($P($G(^VA(200,XRESULT,1)),U,3),"5DZ"),"/","")
"RTN","XUESSO3",410,0)
 . S XOUPN=$P($G(^VA(200,XRESULT,205)),U,5)
"RTN","XUESSO3",411,0)
 . S XOSEC=$TR($P($G(^VA(200,XRESULT,205)),U),"%","^")
"RTN","XUESSO3",412,0)
 . S 
XR(XCOUNT)=XRESULT_"^"_XONME_"^"_XONMEC_"^"_XOSSN_"^"_XODOB_"^"_XOUPN_"^"_XOSEC
"RTN","XUESSO3",413,0)
 Q
"RTN","XUESSO3",414,0)
 ;
"RTN","XUESSO3",415,0)
NAMECOMP(IEN) ;Intrinsic Function. Get NAME COMPONENTS.
"RTN","XUESSO3",416,0)
 N NAME,NC1,NCIEN
"RTN","XUESSO3",417,0)
 S NCIEN=$O(^VA(20,"BB",200,.01,IEN_",",0))
"RTN","XUESSO3",418,0)
 Q:'NCIEN ""
"RTN","XUESSO3",419,0)
 S NC1=$G(^VA(20,NCIEN,1))
"RTN","XUESSO3",420,0)
 Q $TR($P(NC1,U,1,3)_U_$P(NC1,U,5),U,"`")
"RTN","XUESSO3",421,0)
 ;
"RTN","XUESSO3",422,0)
EDITERR(Y,XMSG) ;Intrinsic Subroutine. Add error to list.
"RTN","XUESSO3",423,0)
 N I
"RTN","XUESSO3",424,0)
 S:$P(XMSG,"-1^")="" $E(XMSG,1,3)=""
"RTN","XUESSO3",425,0)
 S I=$O(Y(""),-1)+1,Y(I)=XMSG,Y(0)=-1_U_I
"RTN","XUESSO3",426,0)
 Q
"RTN","XUESSO4")
0^19^B61505269^n/a
"RTN","XUESSO4",1,0)
XUESSO4 ;ISD/HGW Enhanced Single Sign-On Utilities ;12/03/15  15:03
"RTN","XUESSO4",2,0)
 ;;8.0;KERNEL;**659**;Jul 10, 1995;Build 22
"RTN","XUESSO4",3,0)
 ;Per VA Directive 6402, this routine should not be modified.
"RTN","XUESSO4",4,0)
 ;
"RTN","XUESSO4",5,0)
 Q
"RTN","XUESSO4",6,0)
 ;
"RTN","XUESSO4",7,0)
IAMBU(Y,SECID,AUTHCODE,ADUPN) ;RPC. XUS IAM BIND USER - IA #6294
"RTN","XUESSO4",8,0)
 ;Identity and Access Management Edit User RPC for SSOi binding
"RTN","XUESSO4",9,0)
 ; Input:  SECID     = unique Security ID [SecID, assigned by Identity and Access Management]
"RTN","XUESSO4",10,0)
 ;         AUTHCODE  = Security Phrase for IAM Binding Application
"RTN","XUESSO4",11,0)
 ;         ADUPN     = Active Directory UPN
"RTN","XUESSO4",12,0)
 ; Return: Fail    Y = "-1^Error Message"
"RTN","XUESSO4",13,0)
 ;         Success Y = DUZ
"RTN","XUESSO4",14,0)
 ;
"RTN","XUESSO4",15,0)
 ; ZEXCEPT: DIERR ;FileMan special variables
"RTN","XUESSO4",16,0)
 N DUZZERO,FDR,IEN,XARRY,XRESULT,XUENTRY,XUIAM
"RTN","XUESSO4",17,0)
 I DUZ'>1 S Y="-1^Unauthorized access" Q
"RTN","XUESSO4",18,0)
 S XUENTRY=$$GETCNTXT^XUESSO2($G(AUTHCODE)) I +XUENTRY<0 S Y=XUENTRY Q
"RTN","XUESSO4",19,0)
 I $P($G(^XWB(8994.5,XUENTRY,0)),U,1)'="IAM BINDING" S Y="-1^Unauthorized access" Q
"RTN","XUESSO4",20,0)
 S XUIAM=1 ;Do not trigger IAM updates
"RTN","XUESSO4",21,0)
 S XARRY(7)=$G(SECID) ;SecID
"RTN","XUESSO4",22,0)
 I $G(SECID)'="" S XRESULT=$$FINDUSER^XUESSO2(.XARRY)
"RTN","XUESSO4",23,0)
 I (+XRESULT>0)&(XRESULT'=DUZ) S Y="-1^This SecID has already been assigned to another user" Q
"RTN","XUESSO4",24,0)
 ;Use FM calls to edit the user
"RTN","XUESSO4",25,0)
 K ^TMP("DIERR",$J)
"RTN","XUESSO4",26,0)
 S IEN=DUZ_","
"RTN","XUESSO4",27,0)
 S FDR(200,IEN,205.1)=$TR($E($G(SECID),1,40),"^","%")              ;SecID
"RTN","XUESSO4",28,0)
 S FDR(200,IEN,205.2)=$P($G(^XTV(8989.3,1,200)),U,2)               ;Subject Organization
"RTN","XUESSO4",29,0)
 S FDR(200,IEN,205.3)=$P($G(^XTV(8989.3,1,200)),U,3)               ;Subject Organization ID
"RTN","XUESSO4",30,0)
 S FDR(200,IEN,205.4)=$TR($E($G(SECID),1,40),"^","%")              ;Unique User ID
"RTN","XUESSO4",31,0)
 I $D(ADUPN) S FDR(200,IEN,205.5)=$$LOW^XLFSTR($E($G(ADUPN),1,50)) ;ADUPN
"RTN","XUESSO4",32,0)
 ; Apply all the changes: File valid values and reject invalid values (no "T" flag).
"RTN","XUESSO4",33,0)
 S DUZZERO=DUZ(0),DUZ(0)="@" ;Make sure we can update the entry
"RTN","XUESSO4",34,0)
 I $D(FDR) D FILE^DIE("ET","FDR") ;File all the data
"RTN","XUESSO4",35,0)
 S DUZ(0)=DUZZERO ;Restore original FM access
"RTN","XUESSO4",36,0)
 I $D(DIERR) S Y="-1^Error binding VistA user to IAM" Q
"RTN","XUESSO4",37,0)
 S Y=DUZ
"RTN","XUESSO4",38,0)
 Q
"RTN","XUESSO4",39,0)
 ;
"RTN","XUESSO4",40,0)
VACAA(INARRAY,AUTHCODE) ; Veterans Access, Choice, and Accountability Act of 2014 (VACAA)
"RTN","XUESSO4",41,0)
 ; Bulk-load non-VA provider information.
"RTN","XUESSO4",42,0)
 ; This interface is available under a private Integration Agreement (#6230) for support
"RTN","XUESSO4",43,0)
 ; of VACAA only, and should not be used under any other circumstances.
"RTN","XUESSO4",44,0)
 ; Input:  INARRAY(0)  = VISN
"RTN","XUESSO4",45,0)
 ;         INARRAY(1)  = NAME
"RTN","XUESSO4",46,0)
 ;         INARRAY(2)  = DEGREE
"RTN","XUESSO4",47,0)
 ;         INARRAY(3)  = SEX
"RTN","XUESSO4",48,0)
 ;         INARRAY(4)  = STREET ADDRESS 1
"RTN","XUESSO4",49,0)
 ;         INARRAY(5)  = STREET ADDRESS 2
"RTN","XUESSO4",50,0)
 ;         INARRAY(6)  = STREET ADDRESS 3
"RTN","XUESSO4",51,0)
 ;         INARRAY(7)  = CITY
"RTN","XUESSO4",52,0)
 ;         INARRAY(8)  = STATE
"RTN","XUESSO4",53,0)
 ;         INARRAY(9)  = ZIP
"RTN","XUESSO4",54,0)
 ;         INARRAY(10) = NPI
"RTN","XUESSO4",55,0)
 ;         INARRAY(11) = (Optional) TAX ID
"RTN","XUESSO4",56,0)
 ;         INARRAY(12) = DEA #
"RTN","XUESSO4",57,0)
 ;         INARRAY(13) = Subject Organization
"RTN","XUESSO4",58,0)
 ;         INARRAY(14) = Subject Organization ID
"RTN","XUESSO4",59,0)
 ; Return: Fail        = "-1^Error Message"
"RTN","XUESSO4",60,0)
 ;         Neutral     = 0 (not an error, but entry should not be made at this site)
"RTN","XUESSO4",61,0)
 ;         Success     = IEN of NEW PERSON file (#200) entry
"RTN","XUESSO4",62,0)
 ;
"RTN","XUESSO4",63,0)
 ; ZEXCEPT: DA,DD,DIC,DIE,DINUM,DLAYGO,DO,DR
"RTN","XUESSO4",64,0)
 N FADA,FDR,IEN,VIEN,VISN,X,XATTRIB,XDUZ,XIP,XSEC,XSTATE,XTAXID,XUIAM,XUVISN,Y
"RTN","XUESSO4",65,0)
 I 
$$SHAHASH^XUSHSH(256,AUTHCODE)'="69AB5CA7FF413ACA7422D52E466B0C1220BE64C25AFB354E2
915A572E251E560" Q "-1^Unauthorized access"
"RTN","XUESSO4",66,0)
 I '$$PROD^XUPROD Q "-1^Not a production account"
"RTN","XUESSO4",67,0)
 I $G(INARRAY(0))="" Q "-1^Missing VISN"
"RTN","XUESSO4",68,0)
 I $G(INARRAY(1))="" Q "-1^Missing Name"
"RTN","XUESSO4",69,0)
 I $G(INARRAY(4))="" Q "-1^Missing Street Addr"
"RTN","XUESSO4",70,0)
 I $G(INARRAY(7))="" Q "-1^Missing City"
"RTN","XUESSO4",71,0)
 I $G(INARRAY(8))="" Q "-1^Missing State"
"RTN","XUESSO4",72,0)
 I $G(INARRAY(9))="" Q "-1^Missing Zip Code"
"RTN","XUESSO4",73,0)
 I $G(INARRAY(10))="" Q "-1^Missing NPI"
"RTN","XUESSO4",74,0)
 I $G(INARRAY(13))="" Q "-1^Missing Subject Organization"
"RTN","XUESSO4",75,0)
 I $G(INARRAY(14))="" Q "-1^Missing Subject Organization ID"
"RTN","XUESSO4",76,0)
 I '$$CHKDGT^XUSNPI($G(INARRAY(10))) Q "-1^Invalid NPI"
"RTN","XUESSO4",77,0)
 D PARENT^XUAF4("XUVISN","`"_DUZ(2),"VISN") ;Returns XUVISN("P",pien)="VISN #^"
"RTN","XUESSO4",78,0)
 S VIEN=$O(XUVISN("P",0)) S VISN=$TR($P($G(XUVISN("P",VIEN)),U),"VISN ") ;Return VISN number (no 
text)
"RTN","XUESSO4",79,0)
 I VISN'=INARRAY(0) Q 0  ; Only load data appropriate for the site's VISN (not an error)
"RTN","XUESSO4",80,0)
 S DUZ(0)="@",XUIAM=1 ;Temporary high-level access to edit NPF, do not trigger IAM updates
"RTN","XUESSO4",81,0)
 S XATTRIB(8)=INARRAY(10) ; NPI
"RTN","XUESSO4",82,0)
 S XDUZ=$$FINDUSER^XUESSO2(.XATTRIB) ; First find user based on NPI alone
"RTN","XUESSO4",83,0)
 ;Set minimum 4 attributes
"RTN","XUESSO4",84,0)
 S XATTRIB(1)=INARRAY(13) ; Subject Organization
"RTN","XUESSO4",85,0)
 S XATTRIB(2)=INARRAY(14) ; Subject Organization ID
"RTN","XUESSO4",86,0)
 S XATTRIB(3)=XATTRIB(8) ; Unique User ID = NPI per NHIN standard
"RTN","XUESSO4",87,0)
 S XATTRIB(4)=INARRAY(1) ; Subject ID = NAME
"RTN","XUESSO4",88,0)
 I (+XDUZ>0)&('+$$ACTIVE^XUSER(XDUZ)) S XDUZ=$$FINDUSER^XUESSO2(.XATTRIB) ; If not active user, 
lookup on NPI again, update M4A
"RTN","XUESSO4",89,0)
 I +XDUZ<1 S XDUZ=$$ADDUSER^XUESSO2(.XATTRIB) ;Add the new user with M4A
"RTN","XUESSO4",90,0)
 I +XDUZ<1 Q XDUZ  ;Quit with error code from ^XUESSO2
"RTN","XUESSO4",91,0)
 S IEN=XDUZ_","
"RTN","XUESSO4",92,0)
 I $G(INARRAY(2))'="" S FDR(200,IEN,10.6)=$E($G(INARRAY(2)),1,10)  ; DEGREE
"RTN","XUESSO4",93,0)
 I (($G(INARRAY(3))="M")!($G(INARRAY(3))="F")) S FDR(200,IEN,4)=$E($G(INARRAY(3)),1,1)  ; SEX
"RTN","XUESSO4",94,0)
 I $L($G(INARRAY(4)))>2 S FDR(200,IEN,.111)=$E($G(INARRAY(4)),1,50)  ; STREET ADDRESS 1
"RTN","XUESSO4",95,0)
 I $L($G(INARRAY(5)))>2 S FDR(200,IEN,.112)=$E($G(INARRAY(5)),1,50)  ; STREET ADDRESS 2
"RTN","XUESSO4",96,0)
 I $L($G(INARRAY(6)))>2 S FDR(200,IEN,.113)=$E($G(INARRAY(6)),1,50)  ; STREET ADDRESS 3
"RTN","XUESSO4",97,0)
 I $L($G(INARRAY(7)))>2 S FDR(200,IEN,.114)=$E($G(INARRAY(7)),1,30)  ; CITY
"RTN","XUESSO4",98,0)
 I $G(INARRAY(8))'="" D
"RTN","XUESSO4",99,0)
 . I $L($G(INARRAY(8)))>2 S XSTATE="" S XSTATE=$O(^DIC(5,"B",$G(INARRAY(8)),XSTATE))
"RTN","XUESSO4",100,0)
 . I $L($G(INARRAY(8)))=2 D
"RTN","XUESSO4",101,0)
 . . S XIP=""
"RTN","XUESSO4",102,0)
 . . D POSTAL^XIPUTIL($G(INARRAY(9)),.XIP)
"RTN","XUESSO4",103,0)
 . . S XSTATE=$G(XIP("STATE POINTER"))
"RTN","XUESSO4",104,0)
 . I XSTATE'="" S FDR(200,IEN,.115)=XSTATE ; STATE (pointer to ^DIC(5))
"RTN","XUESSO4",105,0)
 I $G(INARRAY(9))'="" S FDR(200,IEN,.116)=$G(INARRAY(9))  ; ZIP CODE
"RTN","XUESSO4",106,0)
 D APPLY(.FDR,IEN) K FDR S IEN=XDUZ_","
"RTN","XUESSO4",107,0)
 S XTAXID=$TR($G(INARRAY(11)),"-","")
"RTN","XUESSO4",108,0)
 I XTAXID'="" D
"RTN","XUESSO4",109,0)
 . S XTAXID=$E(XTAXID,1,2)_"-"_$E(XTAXID,3,9)
"RTN","XUESSO4",110,0)
 . S XTAXID=$TR(XTAXID," ","0")
"RTN","XUESSO4",111,0)
 I (XTAXID'="")&($P($G(^VA(200,XDUZ,"TPB")),U,2)="") S FDR(200,IEN,53.92)=XTAXID  ; TAX ID
"RTN","XUESSO4",112,0)
 D APPLY(.FDR,IEN) K FDR S IEN=XDUZ_","
"RTN","XUESSO4",113,0)
 I $P($G(^VA(200,XDUZ,"TPB")),U,1)="" S FDR(200,IEN,53.91)=1 ; NON-VA PRESCRIBER: (1=YES)
"RTN","XUESSO4",114,0)
 I $P($G(^VA(200,XDUZ,"PS")),U,6)="" S FDR(200,IEN,53.6)=4 ; PROVIDER TYPE: (4=FEE BASIS)
"RTN","XUESSO4",115,0)
 D APPLY(.FDR,IEN) K FDR S IEN=XDUZ_","
"RTN","XUESSO4",116,0)
 I '+$$ACTIVE^XUSER(XDUZ)'="" D  ;Could not get UPDATE^DIE to work consistently for these fields
"RTN","XUESSO4",117,0)
 . I $G(INARRAY(12))'="" D
"RTN","XUESSO4",118,0)
 . . S FDR(200,IEN,53.1)=1 ; AUTHORIZED TO WRITE MED ORDERS: (1=YES)
"RTN","XUESSO4",119,0)
 . . D APPLY(.FDR,IEN)
"RTN","XUESSO4",120,0)
 . . S DIE="^VA(200,",DA=XDUZ,DR="53.2////"_INARRAY(12) ; DEA # (stuff, due to duplicate DEA#s and 
user name changes)
"RTN","XUESSO4",121,0)
 . . L +^VA(200,XDUZ):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) D ^DIE L -^VA(200,XDUZ)
"RTN","XUESSO4",122,0)
 . I $D(^VA(200,XDUZ,"PS")) D
"RTN","XUESSO4",123,0)
 . . I '$P(^VA(200,XDUZ,"PS"),"^",4)!($P(^VA(200,XDUZ,"PS"),"^",4)>DT) D  ;Give user "XUORES" key if 
not an active user
"RTN","XUESSO4",124,0)
 . . . S DA=XDUZ
"RTN","XUESSO4",125,0)
 . . . K DIC S DIC="^DIC(19.1,",DIC(0)="MZ",X="XUORES" D ^DIC
"RTN","XUESSO4",126,0)
 . . . K DIC S FADA=XDUZ
"RTN","XUESSO4",127,0)
 . . . I +Y>0 S X=+Y D
"RTN","XUESSO4",128,0)
 . . . . S:'$D(^VA(200,FADA,51,0)) ^VA(200,FADA,51,0)="^"_$P(^DD(200,51,0),"^",2)_"^^"
"RTN","XUESSO4",129,0)
 . . . . S 
DIC="^VA(200,"_FADA_",51,",DIC(0)="LM",DIC("DR")="1////"_$S($G(DUZ):DUZ,1:"")_";2///"_DT,DLAYG
O=200.051,DINUM=X,DA(1)=FADA
"RTN","XUESSO4",130,0)
 . . . . L +^VA(200,FADA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) K DD,DO D FILE^DICN L -
^VA(200,FADA) K DIC,DR,X,Y
"RTN","XUESSO4",131,0)
 . . I $P($G(^VA(200,XDUZ,"PS")),"^",5)="" D  ; PROVIDER CLASS (pointer to ^DIC(7))
"RTN","XUESSO4",132,0)
 . . . S X=0
"RTN","XUESSO4",133,0)
 . . . S X=$O(^DIC(7,"B","PHYSICIAN",X))
"RTN","XUESSO4",134,0)
 . . . I X>0 D
"RTN","XUESSO4",135,0)
 . . . . S DIE="^VA(200,",DA=XDUZ,DR="53.5////"_X
"RTN","XUESSO4",136,0)
 . . . . L +^VA(200,XDUZ):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) D ^DIE L -^VA(200,XDUZ)
"RTN","XUESSO4",137,0)
 S DUZ(0)=$P($G(^VA(200,DUZ,0)),U,4)
"RTN","XUESSO4",138,0)
 Q XDUZ
"RTN","XUESSO4",139,0)
 ;
"RTN","XUESSO4",140,0)
APPLY(FDR,IEN) ; Apply the changes, used by "VACAA"
"RTN","XUESSO4",141,0)
 ;ZEXCEPT: DIC
"RTN","XUESSO4",142,0)
 K ^TMP("DIERR",$J)
"RTN","XUESSO4",143,0)
 S DIC(0)=""
"RTN","XUESSO4",144,0)
 I $D(FDR) K IEN D UPDATE^DIE("E","FDR","IEN") ;File all the data
"RTN","XUESSO4",145,0)
 Q
"RTN","XUESSO4",146,0)
 ;
"RTN","XUESSO4",147,0)
ESSO(RET,DOC) ; RPC. XUS ESSO VALIDATE - IA #6295
"RTN","XUESSO4",148,0)
 ;This API/RPC uses the VA Identity and Access Management (IAM) SAML token definition version 1.2 
attributes
"RTN","XUESSO4",149,0)
 ; from a STS SAML token for user sign-on.
"RTN","XUESSO4",150,0)
 ; Input:     DOC    = Closed reference to global root containing XML document (loaded STS SAML Token).
"RTN","XUESSO4",151,0)
 ;                     See $$EN^MXMLDOM instructions in the VistA Kernel Developers Guide for required
"RTN","XUESSO4",152,0)
 ;                     format of the DOC global.
"RTN","XUESSO4",153,0)
 ; Return:    RET(0) = DUZ if sign-on was OK, zero if not OK.
"RTN","XUESSO4",154,0)
 ;            RET(1) = (0=OK, 1,2...=Can't sign on for some reason).
"RTN","XUESSO4",155,0)
 ;            RET(2) = Verify Code needs changing.
"RTN","XUESSO4",156,0)
 ;            RET(3) = Message.
"RTN","XUESSO4",157,0)
 ;            RET(4) = 0
"RTN","XUESSO4",158,0)
 ;            RET(5) = count of the number of lines of text, zero if none.
"RTN","XUESSO4",159,0)
 ;            RET(5+n) = message text.
"RTN","XUESSO4",160,0)
 ;
"RTN","XUESSO4",161,0)
 N VCCH,XARRY,XDIV,XDIVA,XOPT,XUDEV,XUF,XUHOME,XUM,XUMSG,XUVOL,X,Y
"RTN","XUESSO4",162,0)
 S U="^",RET(0)=0,RET(5)=0,XUF=$G(XUF,0),XUM=0,XUMSG=0,XUDEV=0
"RTN","XUESSO4",163,0)
 ; Begin user sign-on
"RTN","XUESSO4",164,0)
 S DUZ=0,DUZ(0)="",VCCH=0 D NOW^XUSRB
"RTN","XUESSO4",165,0)
 S XOPT=$$STATE^XWBSEC("XUS XOPT")
"RTN","XUESSO4",166,0)
 S XUVOL=^%ZOSF("VOL")
"RTN","XUESSO4",167,0)
 S XUMSG=$$INHIBIT^XUSRB() I XUMSG S XUM=1 G VAX^XUSRB ;Logon inhibited
"RTN","XUESSO4",168,0)
 ;3 Strikes
"RTN","XUESSO4",169,0)
 I $$LKCHECK^XUSTZIP($G(IO("IP"))) S XUMSG=7 G VAX^XUSRB ;IP locked
"RTN","XUESSO4",170,0)
 S DUZ=$$EN^XUSAML(DOC) ;Process SAML token
"RTN","XUESSO4",171,0)
 I DUZ'>0,$$FAIL^XUS3 D  G VAX^XUSRB
"RTN","XUESSO4",172,0)
 . S XUM=1,XUMSG=7,X=$$RA^XUSTZ H 5 ;3 Strikes
"RTN","XUESSO4",173,0)
 I DUZ'>0 S XUMSG=63 G VAX^XUSRB
"RTN","XUESSO4",174,0)
 D USER^XUS(DUZ) ;Build USER
"RTN","XUESSO4",175,0)
 S XUMSG=$$UVALID^XUS() G:XUMSG VAX^XUSRB ;Check if user is locked out, terminated, or disusered
"RTN","XUESSO4",176,0)
 I ('($G(DUZ("AUTHENTICATION"))="SSOE"))&('($G(DUZ("AUTHENTICATION"))="M4A")) S 
VCCH=$$VCVALID^XUSRB() ;Check if VC needs changing
"RTN","XUESSO4",177,0)
 I DUZ>0 S XUMSG=$$POST^XUSRB(1)
"RTN","XUESSO4",178,0)
 I XUMSG>0 S DUZ=0,VCCH=0 ;If can't sign-on, don't tell need to change VC
"RTN","XUESSO4",179,0)
 I 'XUMSG,VCCH S XUMSG=12 D SET^XWBSEC("XUS DUZ",DUZ) ;Need to change VC
"RTN","XUESSO4",180,0)
 D:DUZ>0 POST2^XUSRB
"RTN","XUESSO4",181,0)
 S RET(0)=DUZ,RET(1)=XUM,RET(2)=VCCH,RET(3)=$S(XUMSG:$$TXT^XUS3(XUMSG),1:""),RET(4)=0
"RTN","XUESSO4",182,0)
 Q
"RTN","XUESSO4",183,0)
 ;
"RTN","XUP")
0^20^B11898665^B11551061
"RTN","XUP",1,0)
XUP ;SFISC/RWF - Setup environment for programmers ;09/02/15  06:36
"RTN","XUP",2,0)
 ;;8.0;KERNEL;**208,258,284,432,469,659**;Jul 10, 1995;Build 22
"RTN","XUP",3,0)
 ;Per VA Directive 6402, this routine should not be modified.
"RTN","XUP",4,0)
 W !,"Setting up programmer environment"
"RTN","XUP",5,0)
 S U="^",$ECODE="",$ETRAP="" ;Clear error and error trap
"RTN","XUP",6,0)
 X ^%ZOSF("TYPE-AHEAD")
"RTN","XUP",7,0)
 ;Check if Production and report
"RTN","XUP",8,0)
 W !,"This is a "_$S($$PROD^XUPROD(1):"PRODUCTION",1:"TEST")_" account.",!
"RTN","XUP",9,0)
 ;
"RTN","XUP",10,0)
 K ^UTILITY($J),^XUTL("XQ",$J) D KILL1^XUSCLEAN
"RTN","XUP",11,0)
 S U="^",DT=$$DT^XLFDT
"RTN","XUP",12,0)
 S XUEOFF=^%ZOSF("EOFF"),XUEON=^%ZOSF("EON"),U="^",XUTT=0,XUIOP=""
"RTN","XUP",13,0)
 D GETENV^%ZOSV S XUENV=Y,XUVOL=$P(Y,U,2),XUCI=$P(Y,U,1)
"RTN","XUP",14,0)
 ;Reset DUZ if user "Switched Identities".
"RTN","XUP",15,0)
 I $D(DUZ("SAV")) S DUZ=+DUZ("SAV"),DUZ(0)=$P(DUZ("SAV"),U,2) K DUZ("SAV")
"RTN","XUP",16,0)
 ;Get user info
"RTN","XUP",17,0)
 I $G(DUZ)>.5,$D(^VA(200,DUZ,0))[0 K DUZ W !,"DUZ Must point to a real user." G EXIT ;p432
"RTN","XUP",18,0)
 I $G(DUZ)>0 D DUZ(DUZ)
"RTN","XUP",19,0)
 I $G(DUZ)'>0!('$D(DUZ(0))) D ASKDUZ G:Y'>0 EXIT
"RTN","XUP",20,0)
 I '$D(XQUSER) S XQUSER=$S($D(^VA(200,DUZ,20)):$P(^(20),"^",2),1:"Unk")
"RTN","XUP",21,0)
 S DTIME=600 ;Set a temp DTIME
"RTN","XUP",22,0)
 S DILOCKTM=+$G(^DD("DILOCKTM"),1) ;p432
"RTN","XUP",23,0)
 S DUZ("LOA")=2 ;p659
"RTN","XUP",24,0)
 S DUZ("AUTHENTICATION")="XUP"
"RTN","XUP",25,0)
 ;Getting Terminal Type
"RTN","XUP",26,0)
ZIS I XUTT D ENQ^XUS1 G:$D(XUIOP(1)) ZIS2 S Y=0 D TT^XUS3 I Y>0 S XUIOP(1)=$P(XUIOP,";",2) G ZIS2
"RTN","XUP",27,0)
 S X="`"_+$G(^VA(200,DUZ,1.2)),DIC="^%ZIS(2,",DIC(0)="MQ"_$S(X]"`0":"",1:"AE") D ^DIC G:Y'>0 EXIT
"RTN","XUP",28,0)
 S XUIOP(1)=$P(Y,U,2) I DIC(0)["A",$G(^VA(200,+DUZ,0))]"" S $P(^VA(200,DUZ,1.2),U,1)=+Y
"RTN","XUP",29,0)
ZIS2 S %ZIS="L",IOP="HOME;"_XUIOP(1) D ^%ZIS G EXIT:POP W !,"Terminal Type set to: ",IOST,!
"RTN","XUP",30,0)
 S DTIME=$$DTIME(DUZ,IOS),DUZ("BUF")=1,XUDEV=IOS
"RTN","XUP",31,0)
 S %=+$G(^VA(200,DUZ,.1)) I %>0 S %=$P(^XTV(8989.3,1,"XUS"),U,15)-($H-%) I %<14,%>0 W !!,"Your 
VERIFY code will expire in "_%_" days",!!
"RTN","XUP",32,0)
 ;Save info, Set last sign-on
"RTN","XUP",33,0)
 D SAVE^XUS1 S $P(^VA(200,DUZ,1.1),"^",1)=$$NOW^XLFDT
"RTN","XUP",34,0)
 ;Check Mail
"RTN","XUP",35,0)
 S Y=$P($G(^XMB(3.7,DUZ,0)),U,6) I Y W !,"You have "_Y_" new message"_$S(Y=1:"",1:"s")_"."
"RTN","XUP",36,0)
 ;Setup error trap
"RTN","XUP",37,0)
 I $$GET^XPAR("USR^SYS","XUS-XUP SET ERROR TRAP",1,"Q") S $ETRAP="D ERR^XUP"
"RTN","XUP",38,0)
 D KILL1^XUSCLEAN S $P(XQXFLG,U,3)="XUP" D ^XQ1
"RTN","XUP",39,0)
EXIT ;Clean-up and exit
"RTN","XUP",40,0)
 D KILL1^XUSCLEAN K XQY,XQY0
"RTN","XUP",41,0)
 I $G(DUZ)>0,$$GET^XPAR("USR^SYS","XUS-XUP VPE",1,"Q"),$D(^%ZVEMS) X ^%ZVEMS ;Run VPE
"RTN","XUP",42,0)
 Q
"RTN","XUP",43,0)
 ;
"RTN","XUP",44,0)
ASKDUZ ;Ask for Access Code
"RTN","XUP",45,0)
 N X
"RTN","XUP",46,0)
 ;X XUEOFF S DIR(0)="FO",DIR("A")="Access Code" D ^DIR W ! X XUEON I $D(DIRUT) S Y=-1 Q
"RTN","XUP",47,0)
 X XUEOFF W !,"Access Code: " S X=$$ACCEPT^XUS() X XUEON
"RTN","XUP",48,0)
 I X["^"!('$L(X)) S Y=-1 Q
"RTN","XUP",49,0)
 S X=$$UP^XLFSTR(X) S:X[":" XUTT=1,X=$P(X,":",1)_$P(X,":",2)
"RTN","XUP",50,0)
 D ^XUSHSH S Y=$O(^VA(200,"A",X,0))
"RTN","XUP",51,0)
 K DUZ D DUZ(+Y)
"RTN","XUP",52,0)
 Q
"RTN","XUP",53,0)
 ;
"RTN","XUP",54,0)
DUZ(DA) ;Build DUZ for a user.  Used by Mailman.
"RTN","XUP",55,0)
 ;(p284) Make the setting of several DUZ parts conditional.
"RTN","XUP",56,0)
 N Y
"RTN","XUP",57,0)
 S Y(0)=$G(^VA(200,+DA,0)),Y("XUS")=$G(^XTV(8989.3,1,"XUS"))
"RTN","XUP",58,0)
 S DUZ=DA
"RTN","XUP",59,0)
 S:$G(DUZ(0))'="@" DUZ(0)=$P(Y(0),"^",4)
"RTN","XUP",60,0)
 S DUZ(1)="",DUZ("AG")=$P($G(^XTV(8989.3,1,0)),"^",8)
"RTN","XUP",61,0)
 S:'$G(DUZ(2)) DUZ(2)=$O(^VA(200,DUZ,2,0))
"RTN","XUP",62,0)
 S:'DUZ(2) DUZ(2)=+$P(Y("XUS"),"^",17)
"RTN","XUP",63,0)
 S:'$L($G(DUZ("LANG"))) DUZ("LANG")=$P(Y("XUS"),"^",7)
"RTN","XUP",64,0)
 Q
"RTN","XUP",65,0)
 ;
"RTN","XUP",66,0)
DTIME(E,D) ;Return DTIME value for user E, device D.
"RTN","XUP",67,0)
 N P
"RTN","XUP",68,0)
 S P=$P($G(^VA(200,+$G(E),200)),"^",10) S:P="" P=$P($G(^%ZIS(1,+$G(D),"XUS")),"^",10) S:P="" 
P=$P($G(^XTV(8989.3,1,"XUS")),"^",10)
"RTN","XUP",69,0)
 Q $S(P]"":P,1:300)
"RTN","XUP",70,0)
 ;
"RTN","XUP",71,0)
ERR ;
"RTN","XUP",72,0)
 N %XUP U $P
"RTN","XUP",73,0)
 W !,"$ECODE=",$ECODE,"   $STACK=",$STACK
"RTN","XUP",74,0)
 W !,"Location: ",$STACK($STACK-1,"PLACE")
"RTN","XUP",75,0)
 R !!,"Want to record the error: No// ",%XUP:600 I "Yy"[$E(%XUP_"N") D ^%ZTER
"RTN","XUP",76,0)
 D UNWIND^%ZTER ;S:'$ESTACK $ECODE="" S $ETRAP="" Q:$QUIT "" Q
"RTN","XUS")
0^7^B35560117^B31567708
"RTN","XUS",1,0)
XUS ;SFISC/STAFF - SIGNON ;09/22/15  09:24
"RTN","XUS",2,0)
 ;;8.0;KERNEL;**16,26,49,59,149,180,265,337,419,434,584,659**;Jul 10, 1995;Build 22
"RTN","XUS",3,0)
 ;Per VA Directive 6402, this routine should not be modified.
"RTN","XUS",4,0)
 ;
"RTN","XUS",5,0)
 ;Sign-on message numbers are 30810.51 to 30810.99
"RTN","XUS",6,0)
 S U="^" D INTRO^XUS1A()
"RTN","XUS",7,0)
 K  K ^XUTL("ZISPARAM",$I)
"RTN","XUS",8,0)
 S U="^",XQXFLG("GUI")="^"
"RTN","XUS",9,0)
 W ! S $Y=0 D SET1(1) I POP S XUM=3 G NO ;Sets DUZ("LANG")
"RTN","XUS",10,0)
 S XUSTMP(51)=$$EZBLD^DIALOG(30810.51),XUSTMP(52)=$$EZBLD^DIALOG(30810.52)
"RTN","XUS",11,0)
 W !!,"Volume set: ",$P(XUENV,U,4),"  UCI: ",XUCI,"  Device: ",$I W:$S('$D(IO("ZIO")):0,1:$I'=IO("ZIO")) " 
(",IO("ZIO"),")" W !
"RTN","XUS",12,0)
RESTART ;
"RTN","XUS",13,0)
 S XUM=$$SET2 G:XUM NO
"RTN","XUS",14,0)
 I $P(XU1,U,2)]"" S XUM=$$DEVPAS() I XUM G H:XUM<0,NO
"RTN","XUS",15,0)
A S (XUSER(0),XUSER(1),XQUR)=""
"RTN","XUS",16,0)
 ;Check for locked IP/device.
"RTN","XUS",17,0)
 I $$LKCHECK^XUSTZIP() S XUM=7,XUFAC=$P(XOPT,U,2),XUHALT=1 G NO
"RTN","XUS",18,0)
 I $G(DUZ("LOA"))="" S DUZ("LOA")=2,DUZ("AUTHENTICATION")="AVCODES"
"RTN","XUS",19,0)
 ;Auto Sign-on check
"RTN","XUS",20,0)
 S X=$$AUTOXUS^XUS1B() I X>0 S DUZ=X,DUZ("AUTHENTICATION")="ASHTOKEN" D USER(DUZ) W !!,">> 
Auto Sign-on: ",$P(XUSER(0),U)," <<<",! G B
"RTN","XUS",21,0)
 X XUEOFF S AV=$$ASKAV() X XUEON I AV="^;^" G H ;Get out
"RTN","XUS",22,0)
 I AV["MAIL-BOX",AV[";XMR" S (XUA,PGM)="XMR",XMCHAN=$P($P(AV,";")," ",2),DUZ=.5 G 
XMR^XUSCLEAN
"RTN","XUS",23,0)
 S XQUR=$P(AV,";",3)
"RTN","XUS",24,0)
 S DUZ=$$CHECKAV(AV) K AV
"RTN","XUS",25,0)
 S XUM=$$UVALID() G:XUM NO
"RTN","XUS",26,0)
B K XUF,%1 S XUF=0 X XUEON
"RTN","XUS",27,0)
 I DUZ D USER^XUS1 G:XUM NO
"RTN","XUS",28,0)
 I DUZ D SEC^XUS3:($D(^%ZIS(1,XUDEV,"TIME"))!$D(^(95))) G:XUM NO
"RTN","XUS",29,0)
 G NO:'DUZ
"RTN","XUS",30,0)
 S DTIME=$P(XOPT,U,10),X=$S(DUZ("BUF"):"",1:"NO-")_"TYPE-AHEAD" X:$D(^%ZOSF(X)) ^(X)
"RTN","XUS",31,0)
 D TT^XUS3:$G(XUTT)
"RTN","XUS",32,0)
 D CLRFAC^XUS3($G(IO("IP")))
"RTN","XUS",33,0)
PGM ;
"RTN","XUS",34,0)
 S Y=+$G(^%ZIS(1,XUDEV,201)) I Y>0,$$CHK S XQY=Y G OK
"RTN","XUS",35,0)
 S Y=+$G(^VA(200,DUZ,201)) I Y>0,$$CHK S XQY=Y G OK
"RTN","XUS",36,0)
 I $D(DUZ("ASH")) S Y=$O(^DIC(19,"B","XU NOP MENU",0)) I Y>0 S XQY=Y G OK ;rwf 403
"RTN","XUS",37,0)
 S XUM=16
"RTN","XUS",38,0)
 G NO
"RTN","XUS",39,0)
 ;
"RTN","XUS",40,0)
OK D CHEK^XQ83
"RTN","XUS",41,0)
 S (XUA,PGM)="XQ"
"RTN","XUS",42,0)
 G NEXT^XUS1
"RTN","XUS",43,0)
 ;
"RTN","XUS",44,0)
CHK() ;Check that option exists and LOCK
"RTN","XUS",45,0)
 I $D(^DIC(19,Y,0)),$S($P(^(0),U,6)="":1,1:$D(^XUSEC($P(^(0),U,6),DUZ))) Q 1
"RTN","XUS",46,0)
 Q 0
"RTN","XUS",47,0)
 ;
"RTN","XUS",48,0)
LC S X=$$UP(X)
"RTN","XUS",49,0)
 Q
"RTN","XUS",50,0)
UP(%) Q $TR(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
"RTN","XUS",51,0)
 ;
"RTN","XUS",52,0)
FAC ;Failed access
"RTN","XUS",53,0)
 S:'DUZ XUF(.1)=$E(%1)
"RTN","XUS",54,0)
 S:XUF=2 XUF(.2)=XUF(.2)+1,XUF(XUF(.2))=%1 S %1="" Q
"RTN","XUS",55,0)
 Q
"RTN","XUS",56,0)
NO ;Tell why didn't get on
"RTN","XUS",57,0)
 S X=$$NO^XUS3() G RESTART:'X ;fall into exit
"RTN","XUS",58,0)
H ;Exit point for all applications
"RTN","XUS",59,0)
C ;CLOSE
"RTN","XUS",60,0)
 G ^XUSCLEAN
"RTN","XUS",61,0)
 ;
"RTN","XUS",62,0)
ON X ^%ZOSF("EON") Q
"RTN","XUS",63,0)
 ;
"RTN","XUS",64,0)
ASKAV(PRE) ;Ask and return Access;Verify code, Turn off echo before calling
"RTN","XUS",65,0)
 N X,Y S PRE=$G(PRE)
"RTN","XUS",66,0)
 F  W !,PRE,XUSTMP(51) S X=$$ACCEPT S:X="^" X="^;^" Q:$L(X)
"RTN","XUS",67,0)
 S X=$TR(X,$C(9),";") ;Convert TAB to ; to match GUI.
"RTN","XUS",68,0)
 I $P(X," ")="MAIL-BOX" S X=X_";XMR"
"RTN","XUS",69,0)
 I $E(X,1,7)="~~TOK~~" Q X ;Use CCOW token
"RTN","XUS",70,0)
 I '$L($P(X,";",2)) W !,PRE,XUSTMP(52) S Y=$$ACCEPT S:Y="^" X="^;" S $P(X,";",2)=Y
"RTN","XUS",71,0)
 Q X
"RTN","XUS",72,0)
 ;
"RTN","XUS",73,0)
 ;Timeout used by XUSTZ call.
"RTN","XUS",74,0)
ACCEPT(TO) ;Read A/V and echo '*' char.
"RTN","XUS",75,0)
 ;Have the Read write to flush the buffer on some systems
"RTN","XUS",76,0)
 N C,A,E K DUOUT S A="",TO=$G(TO,60),E=0
"RTN","XUS",77,0)
 F  D  Q:E
"RTN","XUS",78,0)
 . R "",*C:TO S:('$T) DUOUT=1 S:('$T)!(C=94) A="^"
"RTN","XUS",79,0)
 . I (A="^")!(C=13)!($L(A)>60) S E=1 Q
"RTN","XUS",80,0)
 . I C=127 Q:'$L(A)  S A=$E(A,1,$L(A)-1) W $C(8,32,8) Q
"RTN","XUS",81,0)
 . S A=A_$C(C) W *42
"RTN","XUS",82,0)
 . Q
"RTN","XUS",83,0)
 Q A
"RTN","XUS",84,0)
 ;
"RTN","XUS",85,0)
CHECKAV(X1) ;Check A/V code return DUZ or Zero. (Called from XUSRB)
"RTN","XUS",86,0)
 N %,%1,X,Y,IEN,DA,DIK
"RTN","XUS",87,0)
 S IEN=0
"RTN","XUS",88,0)
 ;Start CCOW
"RTN","XUS",89,0)
 I $E(X1,1,7)="~~TOK~~" D  Q:IEN>0 IEN
"RTN","XUS",90,0)
 . I $E(X1,8,9)="~1" S IEN=$$CHKASH^XUSRB4($E(X1,8,255)),DUZ("AUTHENTICATION")="ASHTOKEN"
"RTN","XUS",91,0)
 . I $E(X1,8,9)="~2" S 
IEN=$$CHKCCOW^XUSRB4($E(X1,8,255)),DUZ("AUTHENTICATION")="CCOWTOKEN"
"RTN","XUS",92,0)
 . Q
"RTN","XUS",93,0)
 ;End CCOW
"RTN","XUS",94,0)
 S X1=$$UP(X1) S:X1[":" XUTT=1,X1=$TR(X1,":")
"RTN","XUS",95,0)
 S X=$P(X1,";") Q:X="^" -1 S:XUF %1="Access: "_X
"RTN","XUS",96,0)
 Q:X'?1.20ANP 0
"RTN","XUS",97,0)
 S X=$$EN^XUSHSH(X) I '$D(^VA(200,"A",X)) D LBAV Q 0
"RTN","XUS",98,0)
 S %1="",IEN=$O(^VA(200,"A",X,0)),XUF(.3)=IEN D USER(IEN)
"RTN","XUS",99,0)
 S X=$P(X1,";",2) S:XUF %1="Verify: "_X S X=$$EN^XUSHSH(X)
"RTN","XUS",100,0)
 I $P(XUSER(1),"^",2)'=X D LBAV Q 0
"RTN","XUS",101,0)
 I $G(XUFAC(1)) S DIK="^XUSEC(4,",DA=XUFAC(1) D ^DIK
"RTN","XUS",102,0)
 I $G(DUZ("AUTHENTICATION"))="" S DUZ("AUTHENTICATION")="AVCODES"
"RTN","XUS",103,0)
 Q IEN
"RTN","XUS",104,0)
LBAV ;Log Bad AV
"RTN","XUS",105,0)
 D:XUF FAC
"RTN","XUS",106,0)
 I IEN S X=$P($G(^VA(200,IEN,1.1)),U,2)+1,$P(^(1.1),"^",2)=X
"RTN","XUS",107,0)
 Q
"RTN","XUS",108,0)
 ;
"RTN","XUS",109,0)
USER(IX) ;Build XUSER
"RTN","XUS",110,0)
 S XUSER(0)=$G(^VA(200,+IX,0)),XUSER(1)=$G(^(.1)),XUSER(1.1)=$G(^(1.1))
"RTN","XUS",111,0)
 Q
"RTN","XUS",112,0)
 ;
"RTN","XUS",113,0)
XUVOL ;Setup XUENV, XUCI,XQVOL,XUVOL,XUOSVER
"RTN","XUS",114,0)
 S U="^" D GETENV^%ZOSV S XUENV=Y,XUCI=$P(Y,U,1),XQVOL=$P(Y,U,2),XUOSVER=$$VERSION^%ZOSV
"RTN","XUS",115,0)
 S X=$O(^XTV(8989.3,1,4,"B",XQVOL,0)),XUVOL=$S(X>0:^XTV(8989.3,1,4,X,0),1:XQVOL_"^y^1")
"RTN","XUS",116,0)
 Q
"RTN","XUS",117,0)
 ;
"RTN","XUS",118,0)
XOPT ;Setup initial XOPT
"RTN","XUS",119,0)
 S XOPT=$S($D(^XTV(8989.3,1,"XUS")):^("XUS"),1:"")
"RTN","XUS",120,0)
 F I=2:1:15 I $P(XOPT,U,I)="" S $P(XOPT,U,I)=$P("^5^900^1^1^^^^1^300^^^^N^90",U,I)
"RTN","XUS",121,0)
 Q
"RTN","XUS",122,0)
 ;
"RTN","XUS",123,0)
SET1(FLAG) ;Setup parameters (also called from XUSRB)
"RTN","XUS",124,0)
 N %
"RTN","XUS",125,0)
 S U="^",XUEON=^%ZOSF("EON"),XUEOFF=^("EOFF")
"RTN","XUS",126,0)
 D XUVOL,XOPT S DUZ("LANG")=$P(XOPT,U,7) ;S:$P(XUVOL,U,6)="y" XRTL=XUCI_","_XQVOL
"RTN","XUS",127,0)
 K ^XUTL("XQ",$J) S XUF=0,XUDEV=0,DUZ=0,DUZ(0)="@",IOS=0,ION=""
"RTN","XUS",128,0)
 I FLAG S %ZIS="L",IOP="HOME" D ^%ZIS Q:POP
"RTN","XUS",129,0)
 S XUDEV=IOS,XUIOP=ION
"RTN","XUS",130,0)
 D GETFAC^XUS3($G(IO("IP")))
"RTN","XUS",131,0)
 S %=$P(XOPT,U,14)
"RTN","XUS",132,0)
 I "N"'[% D
"RTN","XUS",133,0)
 . S XUF=(%["R")+1,XUF(.1)="",XUF(.2)=0,XUF(.3)=0
"RTN","XUS",134,0)
 . I %["D" S:$D(^XTV(8989.3,1,4.33,"B",XUDEV))[0 XUF=0
"RTN","XUS",135,0)
 S DILOCKTM=+$G(^DD("DILOCKTM"),1) ;p434 IA#4909
"RTN","XUS",136,0)
 Q
"RTN","XUS",137,0)
SET2() ;EF. Return error code (also called from XUSRB)
"RTN","XUS",138,0)
 N %,X
"RTN","XUS",139,0)
 S XUNOW=$$HTFM^XLFDT($H),DT=$P(XUNOW,".")
"RTN","XUS",140,0)
 K DUZ,XUSER
"RTN","XUS",141,0)
 S (DUZ,DUZ(2))=0,(DUZ(0),DUZ("AG"),XUSER(0),XUSER(1),XUTT,%UCI)=""
"RTN","XUS",142,0)
 S %=$$INHIBIT^XUSRB() I %>0 Q %
"RTN","XUS",143,0)
 S X=$G(^%ZIS(1,XUDEV,"XUS")),XU1=$G(^(1))
"RTN","XUS",144,0)
 I $L(X) F I=1:1:15 I $L($P(X,U,I)) S $P(XOPT,U,I)=$P(X,U,I)
"RTN","XUS",145,0)
 S DTIME=600
"RTN","XUS",146,0)
 I '$P(XOPT,U,11),$D(^%ZIS(1,XUDEV,90)),^(90)>2800000,^(90)'>DT Q 8
"RTN","XUS",147,0)
 Q 0
"RTN","XUS",148,0)
 ;
"RTN","XUS",149,0)
UVALID() ;EF. Is it valid for this user to sign on?
"RTN","XUS",150,0)
 ;ZEXCEPT: XUM,XUNOW,XUSER ;global Kernel variables used during sign-on
"RTN","XUS",151,0)
 I DUZ'>0 Q 4
"RTN","XUS",152,0)
 I $P(XUSER(1.1),U,5),$P(XUSER(1.1),U,5)>XUNOW S 
XUM(0)=$$FMTE^XLFDT($P(XUSER(1.1),U,5),"2PM") Q 18 ;User locked until
"RTN","XUS",153,0)
 I $P(XUSER(0),U,11),$P(XUSER(0),U,11)'>DT Q 11 ;Access Terminated
"RTN","XUS",154,0)
 I $D(DUZ("ASH")) Q 0 ;If auto handle, Allow to sign-on p434
"RTN","XUS",155,0)
 I $P(XUSER(0),U,7) Q 5 ;Disuser flag set
"RTN","XUS",156,0)
 I 
('$L($P(XUSER(1),U,2)))&('($G(DUZ("AUTHENTICATION"))="SSOE"))&('($G(DUZ("AUTHENTICATION"))="
M4A")) Q 21 ;Null verify code not allowed p419
"RTN","XUS",157,0)
 Q 0
"RTN","XUS",158,0)
 ;
"RTN","XUS",159,0)
DEVPAS() ;EF. Ask device password
"RTN","XUS",160,0)
 X XUEOFF W !,"DEVICE PASSWORD: " R X:60 X XUEON
"RTN","XUS",161,0)
 S X=$E(X,1,30) S:'$T X="^" D LC Q:X["^" -1 I $P(XU1,U,2)'=X S:XUF %1="Device: "_X D:XUF FAC Q 6
"RTN","XUS",162,0)
 Q 0
"RTN","XUS",163,0)
 ;
"RTN","XUS1")
0^10^B29132312^B28568204
"RTN","XUS1",1,0)
XUS1 ;SF-ISC/STAFF - SIGNON ;09/22/15  08:33
"RTN","XUS1",2,0)
 ;;8.0;KERNEL;**9,59,111,165,150,252,265,419,469,523,543,638,659**;Jul 10, 1995;Build 22
"RTN","XUS1",3,0)
 ;Per VA Directive 6402, this routine should not be modified.
"RTN","XUS1",4,0)
 ;User setup
"RTN","XUS1",5,0)
USER ;
"RTN","XUS1",6,0)
 K XUTEXT S XUM=$$USER^XUS1A(),$Y=0
"RTN","XUS1",7,0)
 ;Show post sign-on text
"RTN","XUS1",8,0)
 F I=0:0 S I=$O(XUTEXT(I)) Q:I'>0  D:$Y>20  W:$E(XUTEXT(I),1)="!" ! W $E(XUTEXT(I),2,999)
"RTN","XUS1",9,0)
 . N DIR S DIR(0)="E",DIR("A")="Enter RETURN to continue" D ^DIR W @IOF Q
"RTN","XUS1",10,0)
 ;if XUM=9 multi sign-on NOT allowed
"RTN","XUS1",11,0)
 I XUM=9 W !!,?8,$$EZBLD^DIALOG(30810.45)
"RTN","XUS1",12,0)
 Q:XUM  ;User can't sign-on.
"RTN","XUS1",13,0)
SET ;
"RTN","XUS1",14,0)
 S Y=$$CHKDIV()
"RTN","XUS1",15,0)
 I $P(Y,U,2)>0,$D(^DIC(4,0)) D ASKDIV
"RTN","XUS1",16,0)
 S DUZ(2)=+Y D DUZ^XUS1A
"RTN","XUS1",17,0)
 ;Check verify code
"RTN","XUS1",18,0)
 I $$VCHG D CVC^XUS2 G:$D(DUOUT) H^XUS
"RTN","XUS1",19,0)
 S:$P(XOPT,"^",5) XUTT=1 ;Ask Device
"RTN","XUS1",20,0)
 D ENQ ;Inquire to Terminal Type
"RTN","XUS1",21,0)
 Q
"RTN","XUS1",22,0)
 ;
"RTN","XUS1",23,0)
VCHG() ;Check if the Verify code needs to be changed
"RTN","XUS1",24,0)
 I $D(DUZ("ASH")) Q 0 ;p403
"RTN","XUS1",25,0)
 D:'$D(XUSER) USER^XUS(DUZ)
"RTN","XUS1",26,0)
 Q:'$L($P(XUSER(1),U,2)) 1 ;Null VC
"RTN","XUS1",27,0)
 I $$BROKER^XWBLIB Q:$P(XUSER(0),U,8)=1 0 ;VC never expires, only for BROKER
"RTN","XUS1",28,0)
 Q (XUSER(1)+$P(XOPT,U,15))'>$H ;Time to change
"RTN","XUS1",29,0)
 ;
"RTN","XUS1",30,0)
ASKDIV ;Ask the user for the Division, return Y
"RTN","XUS1",31,0)
 N X
"RTN","XUS1",32,0)
 S DIC="^VA(200,DUZ,2,",DIC(0)="AEQ",DIC("P")="200.02P",X=$O(^VA(200,DUZ,2,"AX1",1,0)) S:X>0 
DIC("B")=$P($$NS^XUAF4(X),U)
"RTN","XUS1",33,0)
 D ^DIC I Y'>0 W !,*7,"You must select one." G ASKDIV
"RTN","XUS1",34,0)
 Q
"RTN","XUS1",35,0)
 ;
"RTN","XUS1",36,0)
CHKDIV(CD) ;ef,sr Check if user needs to select Division.
"RTN","XUS1",37,0)
 N %,%1,%2,%3,%4
"RTN","XUS1",38,0)
 I $G(DUZ("DIV"))>0 Q DUZ("DIV") ;p469 Set outside
"RTN","XUS1",39,0)
 S %=$O(^VA(200,DUZ,2,0)),%1=$O(^(%))
"RTN","XUS1",40,0)
 I %1,$D(CD) D
"RTN","XUS1",41,0)
 . S %2=0,%3=0,CD=0
"RTN","XUS1",42,0)
 . F  S %2=$O(^VA(200,DUZ,2,%2)) Q:%2'>0  S 
%4=^(%2,0),%3=%3+1,CD(%3)=%2_"^"_$$NS^XUAF4(%2)_$S($P(%4,"^",2):"^1",1:"")
"RTN","XUS1",43,0)
 . S CD=%3
"RTN","XUS1",44,0)
 Q %_"^"_%1
"RTN","XUS1",45,0)
 ;
"RTN","XUS1",46,0)
ENQ ;Get terminal type
"RTN","XUS1",47,0)
 S XUT1="" I XUTT X XUEOFF R X:0 X ^%ZOSF("TYPE-AHEAD") W $C(27,91,99) X "R *X:2 I X=27 F  R X#1:2 
S XUT1=XUT1_X Q:'$T!(X=""c"")"
"RTN","XUS1",48,0)
 ;Removed code for Wyse 75
"RTN","XUS1",49,0)
 X XUEON I XUTT,XUT1["[" S Y=$O(^%ZIS(3.22,"B",XUT1,0)) I Y>0 S X=$P($G(^%ZIS(3.22,Y,0)),"^",2)
"RTN","XUS1",50,0)
 I X?1.ANP S DIC="^%ZIS(2,",DIC(0)="MO" D ^DIC I Y>0 S 
XUIOP(1)=$P(Y,U,2),$P(XUIOP,";",2)=XUIOP(1),^VA(200,DUZ,1.2)=+Y
"RTN","XUS1",51,0)
 I '$D(XUIOP(1)),$D(^VA(200,DUZ,1.2)) S X=+^(1.2) I X>0,$D(^%ZIS(2,X,0)) S $P(XUIOP,";",2)=$P(^(0),U)
"RTN","XUS1",52,0)
 Q
"RTN","XUS1",53,0)
 ;
"RTN","XUS1",54,0)
NEXT ;Jump to the next routine
"RTN","XUS1",55,0)
 S IOP=XUIOP D ^%ZIS D SAVE ;Save off device/user info
"RTN","XUS1",56,0)
 S X=$G(^DISV(DUZ)) ;Add kill by session or day here
"RTN","XUS1",57,0)
 S ^DISV(DUZ)=$H
"RTN","XUS1",58,0)
 ;Removed UCI jump p469
"RTN","XUS1",59,0)
 D AUDIT
"RTN","XUS1",60,0)
 S X=$S($D(^VA(200,DUZ,0)):$P($P(^(0),U),","),1:"Unk"),X=$E(X,1,10)_"_"_($J#10000) D SETENV^%ZOSV 
;Set Process Name
"RTN","XUS1",61,0)
 ;S X=$P(XOPT,U,16) X:X ^%ZOSF("PRIORITY")
"RTN","XUS1",62,0)
 D LOG:DUZ,KILL
"RTN","XUS1",63,0)
 K ^XUTL("OR",$J),^UTILITY($J),%UCI
"RTN","XUS1",64,0)
 G ^XQ
"RTN","XUS1",65,0)
 ;
"RTN","XUS1",66,0)
SAVE ;
"RTN","XUS1",67,0)
 N X
"RTN","XUS1",68,0)
 S X="DUZ" F  S X=$Q(@X) Q:X=""  I $D(@X) S ^XUTL("XQ",$J,$TR(X,""""))=@X
"RTN","XUS1",69,0)
 F X="DUZ","IO","IO(""IP"")","IO(""CLNM"")","XQVOL" I $D(@X) S ^XUTL("XQ",$J,X)=@X
"RTN","XUS1",70,0)
 D SAVEVAR^%ZIS ;Save the HOME device variables
"RTN","XUS1",71,0)
 Q
"RTN","XUS1",72,0)
 ;
"RTN","XUS1",73,0)
LOG ;used by R/S and Broker
"RTN","XUS1",74,0)
 N %,XP1,XP2
"RTN","XUS1",75,0)
 S XQXFLG("LLOG")=$P($G(^VA(200,DUZ,1.1)),U) ;Save for LOGIN templates
"RTN","XUS1",76,0)
 S XP1=$$SLOG($P(XUVOL,U,1),,XUDEV,XUCI,$P(XUENV,U,3))
"RTN","XUS1",77,0)
 S %=$$COOKIE($P(^VA(200,DUZ,0),U),XP1) I $L(%) S 
XQXFLG("ZEBRA")=XP1_"~"_%,$P(^XUSEC(0,XP1,0),U,13)=% L +^XWB("SESSION",XQXFLG("ZEBRA")):60
"RTN","XUS1",78,0)
 Q
"RTN","XUS1",79,0)
 ;
"RTN","XUS1",80,0)
 ;Division updated in DIVSET^XUSRB2
"RTN","XUS1",81,0)
 ;The other parameters are in the symbol table with known names.
"RTN","XUS1",82,0)
 ;P1=DUZ,P2=$I,P3=$J,P4=EXIT 
D/T,P5=VOLUME,P6=TASKMAN,P7=XUDEV,P8=UCI,P9=ZIO,P10=NODE,P11=IPV4,P12=CLNM,P13=HANDL
E,P14=REMOTE SITE,P15=REMOTE IEN
"RTN","XUS1",83,0)
 ;P100=IPV6,P101=LOA
"RTN","XUS1",84,0)
SLOG(P5,P6,P7,P8,P10,P14,P15) ;
"RTN","XUS1",85,0)
 ;ZEXCEPT: DILOCKTM ;Global variable for lock timeout
"RTN","XUS1",86,0)
 ;p638 Changes: Save IPv4 address in field 11 (0;11) and IPv6 address in field 100 (1;1)
"RTN","XUS1",87,0)
 N %,I,DA,DIK,N,XL1,XL2,P11,P12,P100,P101
"RTN","XUS1",88,0)
 S XL1=$$NOW^XLFDT
"RTN","XUS1",89,0)
 S P5=$G(P5),P6=$G(P6),P7=$G(P7),P8=$G(P8),P10=$P($G(P10),".")
"RTN","XUS1",90,0)
 S P11=$$FORCEIP4^XLFIPV($G(IO("IP"))),P100=$$FORCEIP6^XLFIPV($G(IO("IP")))
"RTN","XUS1",91,0)
 S P12=$P($G(IO("CLNM")),".")
"RTN","XUS1",92,0)
 I P11="0.0.0.0" S P11=""  ;Do not store null IPv4 address
"RTN","XUS1",93,0)
 I P100="0000:0000:0000:0000:0000:0000:0000:0000" S P100=""  ;Do not store null IPv6 address
"RTN","XUS1",94,0)
 S P101=$G(DUZ("LOA"))
"RTN","XUS1",95,0)
 S 
N=DUZ_"^"_$I_"^"_$J_"^^"_P5_"^"_P6_"^"_P7_"^"_P8_"^"_$E($G(IO("ZIO")),1,30)_"^"_P10_"^"_P11_
"^"_P12
"RTN","XUS1",96,0)
 S:$D(DUZ("VISITOR")) $P(N,U,14,15)=DUZ("VISITOR") ;p523
"RTN","XUS1",97,0)
 S:$G(DUZ(2))>0 $P(N,U,17)=DUZ(2)
"RTN","XUS1",98,0)
 S:$D(DUZ("REMAPP")) $P(N,U,18)=$P(DUZ("REMAPP"),U) ;p523
"RTN","XUS1",99,0)
 F I=XL1:.00000001 L +^XUSEC(0,I):$G(DILOCKTM,5) Q:'$D(^XUSEC(0,I))  L -^XUSEC(0,I)
"RTN","XUS1",100,0)
 S ^XUSEC(0,I,0)=N
"RTN","XUS1",101,0)
 S ^XUSEC(0,I,1)=P100_"^"_P101 ;Save IPv6 address and Level Of Assurance
"RTN","XUS1",102,0)
 L -^XUSEC(0,I)
"RTN","XUS1",103,0)
 S $P(^XUSEC(0,0),"^",3,4)=I_U_(1+$P(^XUSEC(0,0),"^",4))
"RTN","XUS1",104,0)
 S (XL1,DA)=I,DIK="^XUSEC(0," D IX^DIK ;index new entry
"RTN","XUS1",105,0)
 S ^XUTL("XQ",$J,0)=XL1 ;save for sign-off
"RTN","XUS1",106,0)
 I 'P6 S XL2=$G(^VA(200,DUZ,1.1)),$P(XL2,U,1,3)=XL1_"^0^1",$P(XL2,U,5)="",^VA(200,DUZ,1.1)=XL2  ;Set 
last Sign-on
"RTN","XUS1",107,0)
 Q XL1
"RTN","XUS1",108,0)
 ;
"RTN","XUS1",109,0)
COOKIE(J1,J2) ;Call VAdeamon for a cookie
"RTN","XUS1",110,0)
 N ZZ,%
"RTN","XUS1",111,0)
 I $G(XQXFLG("ZEBRA"))=-1 K XQXFLG("ZEBRA") Q "" ;Disabled
"RTN","XUS1",112,0)
 Q:$G(IO("IP"))="" "" ;Not using Telnet or SSH
"RTN","XUS1",113,0)
 Q:$D(DUZ("VISITOR")) "" ;Don't create Handles for visitors p523
"RTN","XUS1",114,0)
 ;
"RTN","XUS1",115,0)
 S %=$$CMD^XWBCAGNT(.ZZ,"XWB CREATE HANDLE",J1_"^"_J2) Q:'% ""
"RTN","XUS1",116,0)
 Q $G(ZZ(1))
"RTN","XUS1",117,0)
 ;
"RTN","XUS1",118,0)
AUDIT ;Set-up Audit info
"RTN","XUS1",119,0)
 N I,I1,I2
"RTN","XUS1",120,0)
 S I=$G(^XTV(8989.3,1,19)),I1=$P(I,U),I2=$P(I,U,2) Q:"asu"'[I1  I (I2>XUNOW)!($P(I,U,3)<XUNOW) Q
"RTN","XUS1",121,0)
 I "au"[I1 S:(I1="a")!($D(^XTV(8989.3,1,19.3,"B",DUZ))>1) XQAUDIT=1 Q
"RTN","XUS1",122,0)
 S XQAUDIT="" F I=0:0 S I=$O(^XTV(8989.3,1,19.1,"B",I)) Q:I'>0!($L(XQAUDIT)>245)  S 
XQAUDIT=XQAUDIT_"2^"_I_U
"RTN","XUS1",123,0)
 S I1="" F I=0:0 S I1=$O(^XTV(8989.3,1,19.2,"B",I1)) Q:I1']""!($L(XQAUDIT)>245)  S 
XQAUDIT=XQAUDIT_"3^"_I1_U
"RTN","XUS1",124,0)
 Q
"RTN","XUS1",125,0)
 ;
"RTN","XUS1",126,0)
DD(Y) Q $$FMTE^XLFDT(Y,1)
"RTN","XUS1",127,0)
 ;
"RTN","XUS1",128,0)
KILL N %UCI,PGM,U,XQUR,XMCHAN G KILL1^XUSCLEAN
"RTN","XUS1",129,0)
 Q
"RTN","XUS1",130,0)
NO G NO^XUS
"RTN","XUSAML")
0^14^B87822485^B78896546
"RTN","XUSAML",1,0)
XUSAML ;ISD/HGW Kernel SAML Token Implementation ;10/01/15  14:40
"RTN","XUSAML",2,0)
 ;;8.0;KERNEL;**655,659**;Jul 10, 1995;Build 22
"RTN","XUSAML",3,0)
 ;Per VA Directive 6402, this routine should not be modified.
"RTN","XUSAML",4,0)
 ;
"RTN","XUSAML",5,0)
 ; Implements the Kernel SAML Token message framework for the Identification and
"RTN","XUSAML",6,0)
 ; Access Management (IAM) Single Sign-On (SSO) security model.
"RTN","XUSAML",7,0)
 ;
"RTN","XUSAML",8,0)
 Q
"RTN","XUSAML",9,0)
EN(DOC) ;Function. Main entry point
"RTN","XUSAML",10,0)
 ;This function parses and processes the VA Identity and Access Management (IAM) STS SAML token
"RTN","XUSAML",11,0)
 ; (version 1.2) and returns the DUZ of the user, if found. It does not log the user into VistA.
"RTN","XUSAML",12,0)
 ; Input:     DOC     = Closed reference to global root containing XML document (loaded STS SAML Token)
"RTN","XUSAML",13,0)
 ;                      Example: S Y=$$EN^XUSAML($NA(^TMP($J,1)))
"RTN","XUSAML",14,0)
 ; Return:    Fail    = "-1^Error Message"
"RTN","XUSAML",15,0)
 ;            Success = DUZ
"RTN","XUSAML",16,0)
 ;ZEXCEPT: XOBDATA ;environment variable
"RTN","XUSAML",17,0)
 N HDL,XASSRT,XUPN,Y
"RTN","XUSAML",18,0)
 K ^TMP("XUSAML",$J)
"RTN","XUSAML",19,0)
 S Y="-1^Error parsing STS SAML Token",XUPN="",XASSRT=""
"RTN","XUSAML",20,0)
 S XOBDATA("XOB RPC","SECURITY","STATE")="notauthenticated"
"RTN","XUSAML",21,0)
 S XOBDATA("XOB RPC","SAML","ASSERTION")="notvalidated"
"RTN","XUSAML",22,0)
 ;--- Call parser
"RTN","XUSAML",23,0)
 S HDL=$$EN^MXMLDOM(DOC,"W")
"RTN","XUSAML",24,0)
 I HDL>0 D
"RTN","XUSAML",25,0)
 . D ND(HDL,1,1,.XUPN,.XASSRT) ;Traverse and process document
"RTN","XUSAML",26,0)
 . S Y="-1^Invalid SAML assertion"
"RTN","XUSAML",27,0)
 . ;Interim solution, code to be deprecated and removed after ???? (date and time)
"RTN","XUSAML",28,0)
 . I $$LOW^XLFSTR($G(^TMP("XUSAML",$J,"Name","authnsystem")))="m4a" D
"RTN","XUSAML",29,0)
 . . S Y=$$FINDUSER()
"RTN","XUSAML",30,0)
 . . I +Y>0 H $E(DT,1,3)-316 ; Add "hang time" as this interface ages to encourage migration
"RTN","XUSAML",31,0)
 . E  D
"RTN","XUSAML",32,0)
 . . ;End of Interim solution, code to be deprecated and removed after ???? (date and time)
"RTN","XUSAML",33,0)
 . . D VALASSRT(.XASSRT,DOC) ;Validate SAML assertion
"RTN","XUSAML",34,0)
 . . I $G(XOBDATA("XOB RPC","SAML","ASSERTION"))="validated" D
"RTN","XUSAML",35,0)
 . . . S Y=$$FINDUSER()
"RTN","XUSAML",36,0)
 . D DELETE^MXMLDOM(HDL)
"RTN","XUSAML",37,0)
 I +Y>0 S XOBDATA("XOB RPC","SECURITY","STATE")="authenticated"
"RTN","XUSAML",38,0)
 K ^TMP("XUSAML",$J)
"RTN","XUSAML",39,0)
 Q Y
"RTN","XUSAML",40,0)
ND(HDL,ND,FS,XUPN,XASSRT) ;SR. Traverse tree
"RTN","XUSAML",41,0)
 N CH,SIB,TX
"RTN","XUSAML",42,0)
 D SH(HDL,ND,.XUPN,.XASSRT)
"RTN","XUSAML",43,0)
 S CH=0
"RTN","XUSAML",44,0)
 S CH=$$CHILD^MXMLDOM(HDL,ND,CH)
"RTN","XUSAML",45,0)
 I CH D ND(HDL,CH,1,.XUPN,.XASSRT)
"RTN","XUSAML",46,0)
 Q:'FS  ;Don't follow the siblings of siblings
"RTN","XUSAML",47,0)
 S SIB=ND
"RTN","XUSAML",48,0)
 F  S SIB=$$SIBLING^MXMLDOM(HDL,SIB) Q:'SIB  D ND(HDL,SIB,0,.XUPN,.XASSRT)
"RTN","XUSAML",49,0)
 Q
"RTN","XUSAML",50,0)
SH(HDL,ND,XUPN,XASSRT) ;SR. Process node elements
"RTN","XUSAML",51,0)
 ;ZEXCEPT: XOBDATA ;environment variable
"RTN","XUSAML",52,0)
 N ELE,I,NM,V,VV,XCHILD,XERR,XTEXT,XVALUE
"RTN","XUSAML",53,0)
 S ELE=$$NAME^MXMLDOM(HDL,ND)
"RTN","XUSAML",54,0)
 ; --------------------  saml:Subject Event Processing  --------------------------------
"RTN","XUSAML",55,0)
 I (ELE="Subject")!(ELE="saml:Subject")!(ELE="ns2:Subject") D  Q  ;Subject element is required
"RTN","XUSAML",56,0)
 . S XASSRT("Subject")="yes"
"RTN","XUSAML",57,0)
 I 
(ELE="SubjectConfirmationData")!(ELE="saml:SubjectConfirmationData")!(ELE="ns2:SubjectConfirmatio
nData") D  Q
"RTN","XUSAML",58,0)
 . D EL(HDL,ND,.NM,.XUPN)
"RTN","XUSAML",59,0)
 . S 
XASSRT("SubjectConfirmationData@Address")=$O(^TMP("XUSAML",$J,"SubjectConfirmationData@Add
ress",""))
"RTN","XUSAML",60,0)
 . S 
XASSRT("SubjectConfirmationData@Recipient")=$O(^TMP("XUSAML",$J,"SubjectConfirmationData@Re
cipient",""))
"RTN","XUSAML",61,0)
 ;
"RTN","XUSAML",62,0)
 ; --------------------  saml:Conditions Event Processing  -------------------------
"RTN","XUSAML",63,0)
 I (ELE="Conditions")!(ELE="saml:Conditions")!(ELE="ns2:Conditions") D  Q
"RTN","XUSAML",64,0)
 . D EL(HDL,ND,.NM,.XUPN)
"RTN","XUSAML",65,0)
 . S XASSRT("NotBefore")=$O(^TMP("XUSAML",$J,"NotBefore",""))
"RTN","XUSAML",66,0)
 . S XASSRT("NotOnOrAfter")=$O(^TMP("XUSAML",$J,"NotOnOrAfter",""))
"RTN","XUSAML",67,0)
 ;
"RTN","XUSAML",68,0)
 ; --------------------  saml:AuthnStatement Event Processing  -------------------------
"RTN","XUSAML",69,0)
 I (ELE="AuthnStatement")!(ELE="saml:AuthnStatement")!(ELE="ns2:AuthnStatement") D  Q
"RTN","XUSAML",70,0)
 . D EL(HDL,ND,.NM,.XUPN)
"RTN","XUSAML",71,0)
 . S XASSRT("AuthnInstant")=$O(^TMP("XUSAML",$J,"AuthnInstant",""))
"RTN","XUSAML",72,0)
 I (ELE="AuthnContextClassRef")!(ELE="saml:AuthnContextClassRef")!(ELE="ns2:AuthnContextClassRef") 
D  Q
"RTN","XUSAML",73,0)
 . S XUPN="AuthnContextClassRef"
"RTN","XUSAML",74,0)
 . D CH(HDL,ND,XUPN)
"RTN","XUSAML",75,0)
 . S XASSRT("AuthnContextClassRef")=$G(^TMP("XUSAML",$J,"AuthnContextClassRef"))
"RTN","XUSAML",76,0)
 ;
"RTN","XUSAML",77,0)
 ; --------------------  saml:Attribute Event Processing  ------------------
"RTN","XUSAML",78,0)
 I (ELE="Attribute")!(ELE="saml:Attribute")!(ELE="ns2:Attribute") D  Q
"RTN","XUSAML",79,0)
 . S XCHILD=$$CHILD^MXMLDOM(HDL,ND) ;Identify child (AttributeValue) of node ND
"RTN","XUSAML",80,0)
 . S XTEXT="" S XERR=$$TEXT^MXMLDOM(HDL,XCHILD,$NA(VV)) ;Get text of AttributeValue
"RTN","XUSAML",81,0)
 . I XERR=1 F I=1:1 Q:'$D(VV(I))  S XTEXT=XTEXT_VV(I)
"RTN","XUSAML",82,0)
 . S NM=""
"RTN","XUSAML",83,0)
 . F  S NM=$$ATTRIB^MXMLDOM(HDL,ND,NM) Q:'$L(NM)  D  ;Get name of Attribute
"RTN","XUSAML",84,0)
 . . I $G(NM)="Name" D
"RTN","XUSAML",85,0)
 . . . S XVALUE=$$VALUE^MXMLDOM(HDL,ND,NM)
"RTN","XUSAML",86,0)
 . . . S ^TMP("XUSAML",$J,NM,XVALUE)=XTEXT ;Set up the ^TMP global for the Attribute
"RTN","XUSAML",87,0)
 Q
"RTN","XUSAML",88,0)
CH(HDL,ND,XUPN) ;SR. Process text node
"RTN","XUSAML",89,0)
 N I,VV,Y
"RTN","XUSAML",90,0)
 I $G(XUPN)'="" D
"RTN","XUSAML",91,0)
 . S Y=""
"RTN","XUSAML",92,0)
 . D TEXT^MXMLDOM(HDL,ND,$NA(VV))
"RTN","XUSAML",93,0)
 . I $D(VV)>2 F I=1:1 Q:'$D(VV(I))  S Y=Y_VV(I)
"RTN","XUSAML",94,0)
 . I $P(XUPN,"^",2)="" D
"RTN","XUSAML",95,0)
 . . S ^TMP("XUSAML",$J,$P(XUPN,"^",1))=Y
"RTN","XUSAML",96,0)
 . E  D
"RTN","XUSAML",97,0)
 . . S ^TMP("XUSAML",$J,$P(XUPN,"^",1),$P(XUPN,"^",2))=Y
"RTN","XUSAML",98,0)
 Q
"RTN","XUSAML",99,0)
EL(HDL,ND,NM,XUPN) ;SR. Process element
"RTN","XUSAML",100,0)
 K XUPN S (NM,XUPN)=""
"RTN","XUSAML",101,0)
 F  S NM=$$ATTRIB^MXMLDOM(HDL,ND,NM) Q:'$L(NM)  D
"RTN","XUSAML",102,0)
 . I $L(NM) S XUPN=NM_"^"_$$VALUE^MXMLDOM(HDL,ND,NM)
"RTN","XUSAML",103,0)
 . I $P(XUPN,"^",2)="" D
"RTN","XUSAML",104,0)
 . . S ^TMP("XUSAML",$J,$P(XUPN,"^",1))=""
"RTN","XUSAML",105,0)
 . E  D
"RTN","XUSAML",106,0)
 . . S ^TMP("XUSAML",$J,$P(XUPN,"^",1),$P(XUPN,"^",2))=""
"RTN","XUSAML",107,0)
 Q
"RTN","XUSAML",108,0)
FINDUSER() ;Function. Identify user
"RTN","XUSAML",109,0)
 ;ZEXCEPT: XOBDATA ;environment variable
"RTN","XUSAML",110,0)
 ;ZEXCEPT: XTMUNIT,XTU ;set for unit testing
"RTN","XUSAML",111,0)
 N VISTAID,X,XARRY,XAUTH,XUIAM,XUHOME,Y,Z
"RTN","XUSAML",112,0)
 I '$$AUTH^XUESSO2() Q "-1^Not an authorized calling routine"
"RTN","XUSAML",113,0)
 S Y="-1^User could not be identified"
"RTN","XUSAML",114,0)
 S XUIAM=1 ;Do not trigger IAM updates
"RTN","XUSAML",115,0)
 S 
XARRY(1)=$$TITLE^XLFSTR($E($G(^TMP("XUSAML",$J,"Name","urn:oasis:names:tc:xspa:1.0:subject:org
anization")),1,50)) ;Subject Organization
"RTN","XUSAML",116,0)
 S 
XARRY(2)=$$LOW^XLFSTR($E($G(^TMP("XUSAML",$J,"Name","urn:oasis:names:tc:xspa:1.0:subject:orga
nization-id")),1,50)) ;Subject Organization ID
"RTN","XUSAML",117,0)
 S XARRY(3)=$G(^TMP("XUSAML",$J,"Name","uniqueUserId")) ;Unique User ID
"RTN","XUSAML",118,0)
 S XARRY(4)=$G(^TMP("XUSAML",$J,"Name","urn:oasis:names:tc:xspa:1.0:subject:subject-id")) ;Subject 
ID
"RTN","XUSAML",119,0)
 ;S XARRY(5)=$G(XASSRT("SubjectConfirmationData@Address")) ;Use to authorize application with 
REMOTE APPLICATION file? Or see SSOe below.
"RTN","XUSAML",120,0)
 S XARRY(6)=$G(^TMP("XUSAML",$J,"Name","urn:va:ad:samaccountname")) ;Network Username
"RTN","XUSAML",121,0)
 S XARRY(7)=$G(^TMP("XUSAML",$J,"Name","urn:va:vrm:iam:secid")) ;SecID
"RTN","XUSAML",122,0)
 S XARRY(8)=$G(^TMP("XUSAML",$J,"Name","urn:oasis:names:tc:xspa:2.0:subject:npi")) ;NPI
"RTN","XUSAML",123,0)
 ;S XARRY(9)=$G(^TMP("XUSAML",$J,"Name","SSN")) ;SSN is not part of STS Token specification v1.2
"RTN","XUSAML",124,0)
 S XARRY(10)=$G(^TMP("XUSAML",$J,"Name","upn")) ;Active Directory User Principle Name (UPN)
"RTN","XUSAML",125,0)
 S XARRY(11)=$G(^TMP("XUSAML",$J,"Name","email")) ;E-Mail Address
"RTN","XUSAML",126,0)
 ;S XARRY(12)=$G(^TMP("XUSAML",$J,"Name","urn:oasis:names:tc:xacml:2.0:subject:role")) ;Role is not 
part of STS Token specification v1.2
"RTN","XUSAML",127,0)
 S XAUTH=$$LOW^XLFSTR($G(^TMP("XUSAML",$J,"Name","authnsystem"))) ;SSOi, SSOe, or Other 
authentication
"RTN","XUSAML",128,0)
 S 
XUHOME=$$LOW^XLFSTR($G(^TMP("XUSAML",$J,"Name","urn:nhin:names:saml:homeCommunityId"))
) ;Home Community ID
"RTN","XUSAML",129,0)
 S VISTAID=$G(^TMP("XUSAML",$J,"Name","urn:va:vrm:iam:vistaid")) ;VISTAID
"RTN","XUSAML",130,0)
 ;S ???=$G(^TMP("XUSAML",$J,"Name","urn:va:vrn:iam:mviicn")) ;ICN - tie PATIENT file (#2) to NEW 
PERSON file (#200)?
"RTN","XUSAML",131,0)
 ;For SSOi and SSOe, the token should come from IAM. Validate using "saml:Issuer" or something from 
the certificate?
"RTN","XUSAML",132,0)
 ;<saml:Issuer Format="urn:oasis:names:tc:SAML:2.0:nameid-
format:entity">https://DNS            /Issuer/SAML2</saml:Issuer>
"RTN","XUSAML",133,0)
 I (XUHOME=$P($G(^XTV(8989.3,1,200)),U,3))&(XAUTH="ssoi") D  ;SSOi
"RTN","XUSAML",134,0)
 . S XARRY(3)=XARRY(7) ;UID=SecID
"RTN","XUSAML",135,0)
 . S Y=$$FINDUSER^XUESSO2(.XARRY) ;Identify user
"RTN","XUSAML",136,0)
 . S DUZ("AUTHENTICATION")="SSOI"
"RTN","XUSAML",137,0)
 . ;I +Y<0 D
"RTN","XUSAML",138,0)
 . ;. ;Future: Add SSOi "VISITOR" entry if not provisioned? Require some sort of Role-based access or 
REMOTE APPLICATION file entry?
"RTN","XUSAML",139,0)
 E  I (XUHOME=$P($G(^XTV(8989.3,1,200)),U,3))&(XAUTH="ssoe") D  ;SSOe
"RTN","XUSAML",140,0)
 . S XARRY(3)=XARRY(7) ;UID=SecID
"RTN","XUSAML",141,0)
 . S Y=$$FINDUSER^XUESSO2(.XARRY) ;Identify user
"RTN","XUSAML",142,0)
 . S DUZ("AUTHENTICATION")="SSOE"
"RTN","XUSAML",143,0)
 . I +Y<0 D
"RTN","XUSAML",144,0)
 . . I $$GETCNTXT^XUESSO2($G(XARRY(2)))>0 D
"RTN","XUSAML",145,0)
 . . . ;For SSOe the XARRY(1) and XARRY(2) will be the CSP that authenticated the user.
"RTN","XUSAML",146,0)
 . . . ; The values will be the CSP friendly name and the mapped SiteID as maintained in MVI.
"RTN","XUSAML",147,0)
 . . . ; Use REMOTE APPLICATION file (#200) where XARRY(1) is application and hashed XARRY(2) is 
authorization code
"RTN","XUSAML",148,0)
 . . . I XARRY(1)'=$P($G(^XTV(8989.3,1,200)),U,2) S Y=$$ADDUSER^XUESSO2(.XARRY)  ;If authorized 
application, add the SSOe user
"RTN","XUSAML",149,0)
 . . . S X=$$SETCNTXT^XUESSO2(Y,$G(XARRY(2)))  ;Add the context option for SSOe
"RTN","XUSAML",150,0)
 E  I (XUHOME=$P($G(^XTV(8989.3,1,200)),U,3))&(XAUTH="m4a") D  ;m4a
"RTN","XUSAML",151,0)
 . S Y=$$FINDUSER^XUESSO2(.XARRY) ;Identify user
"RTN","XUSAML",152,0)
 . S DUZ("AUTHENTICATION")="M4A"
"RTN","XUSAML",153,0)
 E  I 
(XARRY(2)["http://")!(XARRY(2)["https://")!((XARRY(2)["urn:oid:")&(XARRY(2)'=$P($G(^XTV(8989.3,1,200
)),U,3))) D  ; NHIN
"RTN","XUSAML",154,0)
 . I $G(XARRY(3))="" S XARRY(3)=XARRY(8) ;NHIN: UID is NPI if available (preferred)
"RTN","XUSAML",155,0)
 . I $G(XARRY(3))="" S XARRY(3)=XARRY(11) ;NHIN: UID is e-mail if available (alternative to NPI)
"RTN","XUSAML",156,0)
 . S Y=$$FINDUSER^XUESSO2(.XARRY) ;Identify user by NPI or Unique User ID
"RTN","XUSAML",157,0)
 . I +Y<0 D
"RTN","XUSAML",158,0)
 . . S XARRY(8)=""
"RTN","XUSAML",159,0)
 . . S Y=$$FINDUSER^XUESSO2(.XARRY) ;Identify user by Unique User ID only
"RTN","XUSAML",160,0)
 . S DUZ("AUTHENTICATION")="NHIN"
"RTN","XUSAML",161,0)
 ;E  I VISTAID'="" D  ;If there is a VISTAID attribute, check that a DUZ and STATION combination exists for 
this user
"RTN","XUSAML",162,0)
 ;. ;SAML v1.2 specification shows (but current parsing methods will only return a single attribute value):
"RTN","XUSAML",163,0)
 ;. ; <saml:Attribute Name="urn:va:vrm:iam:vistaid">
"RTN","XUSAML",164,0)
 ;. ; <saml:AttributeValue>404-11128439</saml:AttributeValue>
"RTN","XUSAML",165,0)
 ;. ; <saml:AttributeValue>322-22228439</saml:AttributeValue>
"RTN","XUSAML",166,0)
 ;. ; </saml:Attribute>
"RTN","XUSAML",167,0)
 ;. ;Example from IAM shows:
"RTN","XUSAML",168,0)
 ;. ; <saml:Attribute Name="urn:va:vrm:iam:vistaid" 
NameFormat="urn:oasis:names:tc:SAML:2.0:attrname-format:unspecified">
"RTN","XUSAML",169,0)
 ;. ; 
<saml:AttributeValue>200M|33328439^PN^200M^USVHA|A,508|22228439^PN^508^USVHA|A,590|1
1128439^PN^590^USVHA|A</saml:AttributeValue>
"RTN","XUSAML",170,0)
 ;. ; </saml:Attribute>
"RTN","XUSAML",171,0)
 ;. ;***** If VISTAID match, set SECID for user ID'd by DUZ and run $$FINDUSER again to update user 
attributes and authenticate? Self-provisioning!
"RTN","XUSAML",172,0)
 ;. S VID=""
"RTN","XUSAML",173,0)
 ;. F J=1:1 D  Q:VID=""
"RTN","XUSAML",174,0)
 ;. . S VID=$P(VISTAID,",",J)
"RTN","XUSAML",175,0)
 ;. . W !,VID,! ;VID should be "200M|33328439^PN^200M^USVHA|A" where 200M is STATION and 
33328439 is DUZ
"RTN","XUSAML",176,0)
 ;. ;***** Development of identification by VISTAID abandoned in XU*8*659 due to discrepancies 
between standard and IAM example, plus lack of good test data
"RTN","XUSAML",177,0)
 Q Y
"RTN","XUSAML",178,0)
VALASSRT(XASSRT,DOC) ;Intrinsic Subroutine. Validate SAML assertion
"RTN","XUSAML",179,0)
 ;ZEXCEPT: XOBDATA ;environment variable
"RTN","XUSAML",180,0)
 N XD,XNOW
"RTN","XUSAML",181,0)
 S XOBDATA("XOB RPC","SAML","AUTHENTICATION 
TYPE")=$G(^TMP("XUSAML",$J,"Name","authenticationtype"))
"RTN","XUSAML",182,0)
 S XOBDATA("XOB RPC","SAML","PROOFING 
AUTHORITY")=$G(^TMP("XUSAML",$J,"Name","proofingauthority"))
"RTN","XUSAML",183,0)
 ;Validate timestamps (e.g., NotBefore, NotOnOrAfter)
"RTN","XUSAML",184,0)
 S XNOW=$$NOW^XLFDT
"RTN","XUSAML",185,0)
 S XD=$$CONVTIME($G(XASSRT("AuthnInstant"))) I XD=-1 Q  ;invalid timestamp
"RTN","XUSAML",186,0)
 S XD=$$CONVTIME($G(XASSRT("NotBefore"))) I (XD=-1)!(XD>XNOW) Q  ;token not valid yet
"RTN","XUSAML",187,0)
 S XD=$$CONVTIME($G(XASSRT("NotOnOrAfter"))) I (XD=-1)!(XD'>XNOW) Q  ;token expired
"RTN","XUSAML",188,0)
 ;Validate endpoints (Optional based on scenario)
"RTN","XUSAML",189,0)
 I '$D(XASSRT("Subject")) Q  ;very basic check for "Subject" tag
"RTN","XUSAML",190,0)
 ; - TBD
"RTN","XUSAML",191,0)
 ;  a) Validate Subject::SubjectConfirmation::SubjectConfirmationData@Address
"RTN","XUSAML",192,0)
 ;     matches the requestor (e.g., common name in this attribute matches that
"RTN","XUSAML",193,0)
 ;     from the certificate which secured the session). Note: This Subject will
"RTN","XUSAML",194,0)
 ;     be the system that requested the token - it may or may not be the System
"RTN","XUSAML",195,0)
 ;     handing the token to VistA.
"RTN","XUSAML",196,0)
 ;     As of patch 659, IAM SAML tokens are missing this information
"RTN","XUSAML",197,0)
 ;  b) Validate Service Endpoint using
"RTN","XUSAML",198,0)
 ;     Subject::SubjectConfirmation::SubjectConfirmationData@Recipient
"RTN","XUSAML",199,0)
 ;     VistA shall accept an endpoint of "DNS   "
"RTN","XUSAML",200,0)
 ;     As of patch 659, IAM SAML tokens have this information in the wrong place:
"RTN","XUSAML",201,0)
 ;     <saml:SubjectConfirmationData Recipient="http://SSOi/AppliesTo/SAML2"/>
"RTN","XUSAML",202,0)
 ;     
<saml:AudienceRestriction><saml:Audience>https://*.DNS   /*</saml:Audience></saml:AudienceRestri
ction>
"RTN","XUSAML",203,0)
 I '$D(XASSRT("AuthnContextClassRef")) Q
"RTN","XUSAML",204,0)
 ; - TBD
"RTN","XUSAML",205,0)
 ; Verify Level of Assurance (VA requires LOA-1 through LOA-3, but LOA-4 is currently the best)
"RTN","XUSAML",206,0)
 K XOBDATA("XOB RPC","SAML","ASSURANCE LEVEL")
"RTN","XUSAML",207,0)
 S XD=$G(^TMP("XUSAML",$J,"Name","assurancelevel")) I (+XD<1)!(+XD="") S XD=1
"RTN","XUSAML",208,0)
 S XOBDATA("XOB RPC","SAML","ASSURANCE LEVEL")=XD
"RTN","XUSAML",209,0)
 S DUZ("LOA")=XD ;Set LOA environment variable for SIGN-ON log and permissions
"RTN","XUSAML",210,0)
 ;Validate Digital Signature
"RTN","XUSAML",211,0)
 I '$$VALIDATE^XUCERT(DOC) Q
"RTN","XUSAML",212,0)
 ;Validate Token Issuer (Subject of X509 Certificate used to sign token)
"RTN","XUSAML",213,0)
 I '($G(XOBDATA("XOB RPC","SAML","ISSUER"))[$P($G(^XTV(8989.3,1,200)),U,1)) Q
"RTN","XUSAML",214,0)
 ;Token has been validated
"RTN","XUSAML",215,0)
 S XOBDATA("XOB RPC","SAML","ASSERTION")="validated"
"RTN","XUSAML",216,0)
 Q
"RTN","XUSAML",217,0)
CONVTIME(TIME) ;Intrinsic Function. Convert XML time to FileMan format
"RTN","XUSAML",218,0)
 ;ZEXCEPT: %DT ;environment variable
"RTN","XUSAML",219,0)
 N X,XD,XOUT,XT,XZ,Y
"RTN","XUSAML",220,0)
 S XZ=0 I $G(TIME)["Z" S XZ=1 ;Zulu time (GMT)
"RTN","XUSAML",221,0)
 S XD=$P($G(TIME),"T",1) ;Date
"RTN","XUSAML",222,0)
 S XD=$P(XD,"-",2)_"/"_$P(XD,"-",3)_"/"_$P(XD,"-",1) ;Convert date to MM/DD/YYYY
"RTN","XUSAML",223,0)
 S XT=$P($G(TIME),"T",2) ;Time
"RTN","XUSAML",224,0)
 I XZ=1 S XT=$P(XT,"Z",1) ;Strip "Z" from time
"RTN","XUSAML",225,0)
 S X=XD_"@"_XT S %DT="RTS"
"RTN","XUSAML",226,0)
 D ^%DT S XOUT=Y
"RTN","XUSAML",227,0)
 I XZ=1 S XOUT=$$FMADD^XLFDT(XOUT,0,+$E($$TZ^XLFDT,1,3),0,0) ;Adjust from GMT
"RTN","XUSAML",228,0)
 K %DT(0)
"RTN","XUSAML",229,0)
 Q XOUT
"RTN","XUSBSE1")
0^9^B158984065^B117144392
"RTN","XUSBSE1",1,0)
XUSBSE1 ;ISF/JLI,ISD/HGW - MODIFICATIONS FOR BSE ;01/06/16  16:37
"RTN","XUSBSE1",2,0)
 ;;8.0;KERNEL;**404,439,523,595,522,638,659**;Jul 10, 1995;Build 22
"RTN","XUSBSE1",3,0)
 ;Per VA Directive 6402, this routine should not be modified.
"RTN","XUSBSE1",4,0)
 ;
"RTN","XUSBSE1",5,0)
 Q
"RTN","XUSBSE1",6,0)
SETVISIT(RES) ; RPC. XUS SET VISITOR - IA #5501
"RTN","XUSBSE1",7,0)
 ;Returns a BSE TOKEN
"RTN","XUSBSE1",8,0)
 N TOKEN,O,X
"RTN","XUSBSE1",9,0)
 S X=$$ACTIVE^XUSER(DUZ) I $P(X,U)<1 S RES=X Q  ;User must be active
"RTN","XUSBSE1",10,0)
 S TOKEN=$$HANDLE^XUSRB4("XUSBSE",1)
"RTN","XUSBSE1",11,0)
 I TOKEN="NOT AUTHENTICATED" S RES=TOKEN Q  ;User must be authenticated
"RTN","XUSBSE1",12,0)
 S ^XTMP(TOKEN,1)=$$ENCRYP^XUSRB1($$GET^XUESSO1(DUZ))
"RTN","XUSBSE1",13,0)
 S ^XTMP(TOKEN,3)=+$H ;Set expiration day
"RTN","XUSBSE1",14,0)
 L -^XTMP(TOKEN) ;Lock set in $$HANDLE^XUSRB4
"RTN","XUSBSE1",15,0)
 S RES=TOKEN
"RTN","XUSBSE1",16,0)
 Q
"RTN","XUSBSE1",17,0)
 ;
"RTN","XUSBSE1",18,0)
GETVISIT(RES,TOKEN) ; RPC. XUS GET VISITOR - IA #5532
"RTN","XUSBSE1",19,0)
 ;Returns demographics for user indicated by TOKEN
"RTN","XUSBSE1",20,0)
 ;  or "-1^error message" if user is not permitted to visit
"RTN","XUSBSE1",21,0)
 ;   input  - TOKEN - token value returned by remote site
"RTN","XUSBSE1",22,0)
 ;   output - RES - passed by reference, contains user demographics on return
"RTN","XUSBSE1",23,0)
 N O,X
"RTN","XUSBSE1",24,0)
 S RES="",O=0
"RTN","XUSBSE1",25,0)
 I TOKEN="" S X=$$LOGERR("BSE NULL TOKEN") Q  ;Shouldn't come in with a null token
"RTN","XUSBSE1",26,0)
 L +^XTMP(TOKEN):10 I '$T Q  ; If ^XTMP is purged, token context will be lost
"RTN","XUSBSE1",27,0)
 I ($G(^XTMP(TOKEN,3))-$H) K ^XTMP(TOKEN) Q  ;Check expiration time, and if it has passed
"RTN","XUSBSE1",28,0)
 S RES=$G(^XTMP(TOKEN,1)) S:$L(RES) RES=$$DECRYP^XUSRB1(RES)
"RTN","XUSBSE1",29,0)
 L -^XTMP(TOKEN) ;Lock set in $$HANDLE^XUSRB4
"RTN","XUSBSE1",30,0)
 S:'$L(RES) X=$$LOGERR("BSE GET USER ID") ;p595
"RTN","XUSBSE1",31,0)
 Q
"RTN","XUSBSE1",32,0)
 ;
"RTN","XUSBSE1",33,0)
OLDCAPRI(XWBUSRNM) ; Intrinsic. Old CAPRI code, currently used by MDWS: Disable with system 
parameter XU522.
"RTN","XUSBSE1",34,0)
 ; Return 1 if a valid user, else 0.
"RTN","XUSBSE1",35,0)
 
;************************************************************************************
**********************************
"RTN","XUSBSE1",36,0)
 ;***** This interface is deprecated as of patch XU*8.0*522 and will be permanently disabled with patch 
XU*8.0*617 *****
"RTN","XUSBSE1",37,0)
 
;************************************************************************************
**********************************
"RTN","XUSBSE1",38,0)
 ; ZEXCEPT: DTIME - Kernel exemption
"RTN","XUSBSE1",39,0)
 N XVAL,XOPTION,XVAL522
"RTN","XUSBSE1",40,0)
 S XVAL522=$$GET^XPAR("SYS","XU522",1,"Q")  ; p522 system parameter XU522 controls CAPRI login 
disabling, logging
"RTN","XUSBSE1",41,0)
 D:(XVAL522="E"!(XVAL522="L")) APPERROR^%ZTER("OLDCAPRI LOGIN ATTEMPT")  ; p522 record CAPRI 
login attempt if XU522 = E or L
"RTN","XUSBSE1",42,0)
 Q:(XVAL522'="L")&(XVAL522'="N") 0  ; p522 fully activate BSE unless param XU522 = N or L
"RTN","XUSBSE1",43,0)
 S DUZ("LOA")=1,DUZ("AUTHENTICATION")="NONE",DUZ("REMAPP")="^MDWS"
"RTN","XUSBSE1",44,0)
 S XVAL=$$PUT^XUESSO1($P(XWBUSRNM,U,3,99)) ; Sign in as Visitor
"RTN","XUSBSE1",45,0)
 I XVAL D
"RTN","XUSBSE1",46,0)
 . S XOPTION=$$FIND1^DIC(19,"","X","DVBA CAPRI GUI")
"RTN","XUSBSE1",47,0)
 . D SETCNTXT(XOPTION) S DTIME=$$DTIME^XUP(DUZ),DUZ(0)=""
"RTN","XUSBSE1",48,0)
 . N XUAPIEN,XUUCYES,XURPIEN
"RTN","XUSBSE1",49,0)
 . S XUAPIEN=$O(^VA(201,"B","APPLICATION PROXY",0)) Q:XUAPIEN'>0  ; Get IEN of "APPLICATON 
PROXY" User Class
"RTN","XUSBSE1",50,0)
 . S XUUCYES=$O(^VA(200,DUZ,"USC3","B",XUAPIEN,0)) Q:XUUCYES'>0   ; Check if DUZ is APPLICATION 
PROXY
"RTN","XUSBSE1",51,0)
 . ;I XUUCYES=XUAPIEN S XVAL=0  ; Application Proxy use of this interface is not permitted
"RTN","XUSBSE1",52,0)
 Q $S(XVAL>0:1,1:0)
"RTN","XUSBSE1",53,0)
 ;
"RTN","XUSBSE1",54,0)
CHKUSER(INPUTSTR) ; Extrinsic. Determines if a BSE sign-on is valid - called from XUSRB
"RTN","XUSBSE1",55,0)
 ;   INPUTSTR - input - String of characters from client
"RTN","XUSBSE1",56,0)
 ;   return value - 1 if a valid user and application, else 0
"RTN","XUSBSE1",57,0)
 ; ZEXCEPT: DTIME - Kernel exemption
"RTN","XUSBSE1",58,0)
 N X,XUCODE,XUENTRY,XUSTR,XUTOKEN
"RTN","XUSBSE1",59,0)
 I +INPUTSTR=-31,INPUTSTR["DVBA_" Q $$OLDCAPRI(INPUTSTR)
"RTN","XUSBSE1",60,0)
 I +INPUTSTR'=-35 S X=$$LOGERR("BSE LOGIN ERROR") Q 0  ; not a BSE login
"RTN","XUSBSE1",61,0)
 S INPUTSTR=$P(INPUTSTR,U,2,99)
"RTN","XUSBSE1",62,0)
 K ^TMP("XUSBSE1",$J)
"RTN","XUSBSE1",63,0)
 S XUCODE=$$DECRYP^XUSRB1(INPUTSTR)
"RTN","XUSBSE1",64,0)
 S XUENTRY=$$GETCNTXT^XUESSO2($P(XUCODE,U))
"RTN","XUSBSE1",65,0)
 I XUENTRY'>0 S X=$$LOGERR("BSE LOGIN ERROR - REMAPP") Q 0  ; invalid remote application
"RTN","XUSBSE1",66,0)
 S DUZ("LOA")=2,DUZ("AUTHENTICATION")="BSETOKEN"
"RTN","XUSBSE1",67,0)
 S DUZ("REMAPP")=XUENTRY_U_$$GET1^DIQ(8994.5,XUENTRY_",",.01)
"RTN","XUSBSE1",68,0)
 S XUTOKEN=$P(XUCODE,U,2)
"RTN","XUSBSE1",69,0)
 S XUSTR=$P(XUCODE,U,3,4)
"RTN","XUSBSE1",70,0)
 S XUENTRY=$$BSEUSER(XUENTRY,XUTOKEN,XUSTR)
"RTN","XUSBSE1",71,0)
 S DTIME=$$DTIME^XUP(DUZ)
"RTN","XUSBSE1",72,0)
 I XUENTRY'>0 S X=$$LOGERR("BSE LOGIN ERROR - USER") Q 0  ; invalid user
"RTN","XUSBSE1",73,0)
 Q XUENTRY
"RTN","XUSBSE1",74,0)
 ;
"RTN","XUSBSE1",75,0)
BSEUSER(ENTRY,TOKEN,STR) ; Intrinsic. Returns internal entry number for authenticated user
"RTN","XUSBSE1",76,0)
 ;   ENTRY - input - internal entry number in REMOTE APPLICATION file
"RTN","XUSBSE1",77,0)
 ;   TOKEN - input - token from authenticating site
"RTN","XUSBSE1",78,0)
 ;   STR   - input - remainder of input string (station #^TCP/IP port for station-based authentication)
"RTN","XUSBSE1",79,0)
 ;   returns - IEN for authenticated user, or 0 if not authenticated
"RTN","XUSBSE1",80,0)
 ; ZEXCEPT: XWBSEC - Kernel exemption, contains error message returned to GUI application
"RTN","XUSBSE1",81,0)
 N X,XUIEN,XUCONTXT,XUDEMOG,XCNT,XVAL,ARRAY,XUCACHE,XUCONTXT
"RTN","XUSBSE1",82,0)
 S XUIEN=0,XUDEMOG="",XUCONTXT=0
"RTN","XUSBSE1",83,0)
 ; Check for cached user authentication (p638)
"RTN","XUSBSE1",84,0)
 I $D(^XTMP("XUSBSE1",TOKEN)) D
"RTN","XUSBSE1",85,0)
 . S XUCACHE=$G(^XTMP("XUSBSE1",TOKEN)) ; Retrieve cached values
"RTN","XUSBSE1",86,0)
 . I $P($P(XUCACHE,U,1),".",1)<$$DT^XLFDT() K ^XTMP("XUSBSE1",TOKEN) Q  ; Do not use if expired (not 
from today)
"RTN","XUSBSE1",87,0)
 . I $P(XUCACHE,U,1)=$$HADD^XLFDT($$NOW^XLFDT(),0,0,0,600) K ^XTMP("XUSBSE1",TOKEN) Q  ; Do 
not use if expired (older than 600s)
"RTN","XUSBSE1",88,0)
 . S XUDEMOG=$P(XUCACHE,U,3,99) ; Get demographics of authenticated user
"RTN","XUSBSE1",89,0)
 . I '$$PUT^XUESSO1(XUDEMOG) Q  ; Set VISITOR entry, quit if failed
"RTN","XUSBSE1",90,0)
 . S XUIEN=$G(DUZ)
"RTN","XUSBSE1",91,0)
 . S XUCONTXT=$P(XUCACHE,U,2),^XUTL("XQ",$J,"DUZ(BSE)")=XUCONTXT ; Set Context Option
"RTN","XUSBSE1",92,0)
 . S:(XUIEN>0) ^XTMP("XUSBSE1",TOKEN)=$$NOW^XLFDT()_"^"_$G(XUCONTXT)_"^"_XUDEMOG ; Reset 
cache to keep authentication alive
"RTN","XUSBSE1",93,0)
 I (XUIEN>0)&(XUCONTXT>0) Q XUIEN  ; p638 Use cached authentication
"RTN","XUSBSE1",94,0)
 ;
"RTN","XUSBSE1",95,0)
 S XCNT=0 F  S XCNT=$O(^XWB(8994.5,ENTRY,1,XCNT)) Q:XCNT'>0  S XVAL=^(XCNT,0) D  
Q:XUDEMOG'=""
"RTN","XUSBSE1",96,0)
 . ; CODE TO HANDLE CONNECTION TYPE AND CONNECTIONS
"RTN","XUSBSE1",97,0)
 . I $P(XVAL,U)="M" S XUDEMOG=$$M2M($P(XVAL,U,3),$P(XVAL,U,2),TOKEN) D CLOSE^XWBM2MC() Q  
; M2M-Broker authentication
"RTN","XUSBSE1",98,0)
 . I $P(XVAL,U)="R" S XUDEMOG=$$XWB($P(XVAL,U,3),$P(XVAL,U,2),TOKEN) Q  ; RPC-Broker 
authentication
"RTN","XUSBSE1",99,0)
 . I $P(XVAL,U)="H" S 
XUDEMOG=$$POST1^XUSBSE2(.ARRAY,$P(XVAL,U,3),$P(XVAL,U,2),$P(XVAL,U,4),"xVAL="_TOKEN) Q  ; 
HTTP authentication
"RTN","XUSBSE1",100,0)
 . I $P(XVAL,U)="S" S XUDEMOG=$$HOME(TOKEN,XVAL,STR) Q  ; Station-number authentication
"RTN","XUSBSE1",101,0)
 . Q
"RTN","XUSBSE1",102,0)
 ; if invalid set XWBSEC so an error is reported in the GUI application
"RTN","XUSBSE1",103,0)
 I +XUDEMOG=-1 S XWBSEC="BSE ERROR - "_$P(XUDEMOG,"^",2)
"RTN","XUSBSE1",104,0)
 I $L(XUDEMOG,"^")>2 D
"RTN","XUSBSE1",105,0)
 . S XUCONTXT=$P($G(^XWB(8994.5,ENTRY,0)),U,2)
"RTN","XUSBSE1",106,0)
 . S XUIEN=$$SETUP(XUDEMOG,XUCONTXT)
"RTN","XUSBSE1",107,0)
 S:(XUIEN'>0) X=$$LOGERR("BSE LOGIN ERROR") ;p595
"RTN","XUSBSE1",108,0)
 S:(XUIEN>0) ^XTMP("XUSBSE1",TOKEN)=$$NOW^XLFDT()_"^"_$G(XUCONTXT)_"^"_XUDEMOG ; p638 
Cache user authentication
"RTN","XUSBSE1",109,0)
 Q $S(XUIEN'>0:0,1:XUIEN)
"RTN","XUSBSE1",110,0)
 ;
"RTN","XUSBSE1",111,0)
XWB(SERVER,PORT,TOKEN) ; Special Broker service
"RTN","XUSBSE1",112,0)
 N DEMOSTR,IO,XWBTDEV,XWBRBUF
"RTN","XUSBSE1",113,0)
 Q $$CALLBSE^XWBTCPM2(SERVER,PORT,TOKEN)
"RTN","XUSBSE1",114,0)
 ;
"RTN","XUSBSE1",115,0)
M2M(SERVER,PORT,TOKEN) ; M2M Broker
"RTN","XUSBSE1",116,0)
 N DEMOGSTR,XWBCRLFL,RETRNVAL,XUSBSARR
"RTN","XUSBSE1",117,0)
 S DEMOGSTR=""
"RTN","XUSBSE1",118,0)
 N XWBSTAT,XWBPARMS,XWBTDEV,XWBNULL
"RTN","XUSBSE1",119,0)
 S XWBPARMS("ADDRESS")=SERVER,XWBPARMS("PORT")=PORT
"RTN","XUSBSE1",120,0)
 S XWBPARMS("RETRIES")=3 ;Retries 3 times to open
"RTN","XUSBSE1",121,0)
 ;
"RTN","XUSBSE1",122,0)
 I '$$OPEN^XWBRL(.XWBPARMS) Q "NO OPEN"
"RTN","XUSBSE1",123,0)
 S XWBPARMS("URI")="XUS GET VISITOR"
"RTN","XUSBSE1",124,0)
 D CLEARP^XWBM2MEZ
"RTN","XUSBSE1",125,0)
 D SETPARAM^XWBM2MEZ(1,"STRING",TOKEN)
"RTN","XUSBSE1",126,0)
 S XWBPARMS("URI")="XUS GET VISITOR"
"RTN","XUSBSE1",127,0)
 S XWBPARMS("RESULTS")=$NA(^TMP("XUSBSE1",$J))
"RTN","XUSBSE1",128,0)
 S XWBCRLFL=0
"RTN","XUSBSE1",129,0)
 D REQUEST^XWBRPCC(.XWBPARMS)
"RTN","XUSBSE1",130,0)
 I XWBCRLFL S RETRNVAL="XWBCRLFL IS TRUE" G M2MEXIT
"RTN","XUSBSE1",131,0)
 ;
"RTN","XUSBSE1",132,0)
 I '$$EXECUTE^XWBVLC(.XWBPARMS) S RETRNVAL="FAILURE ON EXECUTE" G M2MEXIT ;Run RPC and 
place raw XML results in ^TMP("XWBM2MVLC"
"RTN","XUSBSE1",133,0)
 D PARSE^XWBRPC(.XWBPARMS,"XUSBSARR") ;Parse out raw XML and place results in 
^TMP("XWBM2MRPC"
"RTN","XUSBSE1",134,0)
 S RETRNVAL=$G(XUSBSARR(1))
"RTN","XUSBSE1",135,0)
M2MEXIT ;
"RTN","XUSBSE1",136,0)
 D CLOSE^XWBM2MEZ
"RTN","XUSBSE1",137,0)
 Q RETRNVAL
"RTN","XUSBSE1",138,0)
 ;
"RTN","XUSBSE1",139,0)
HOME(TOKEN,RAD,BSE) ; Call home station for token.
"RTN","XUSBSE1",140,0)
 ;   input TOKEN  - token to identify user to authenticating server
"RTN","XUSBSE1",141,0)
 ;   input RAD    - Zero node of application data from REMOTE APPLICATION file (#8994.5)
"RTN","XUSBSE1",142,0)
 ;   input BSE    - Station #^TCP/IP port
"RTN","XUSBSE1",143,0)
 ; returns        - string of demographic characteristics or "-1^error message"
"RTN","XUSBSE1",144,0)
 N X,XUESSO,PORT,STN,IP,STNIEN,XUCACHE,STNPRNT
"RTN","XUSBSE1",145,0)
 D:$G(XWBDEBUG) LOG^XWBDLOG("ENTERED HOME BSE: "_BSE) ; DEBUG
"RTN","XUSBSE1",146,0)
 Q:$P(RAD,U,2)'=-1 "" ;Not setup right
"RTN","XUSBSE1",147,0)
 ;Set Station #, port from passed in data
"RTN","XUSBSE1",148,0)
 S STN=$P(BSE,U),PORT=$P(BSE,U,2),XUESSO=""
"RTN","XUSBSE1",149,0)
 ; Check if STN is a valid station number in the INSTITUTION file (security check)
"RTN","XUSBSE1",150,0)
 S STNIEN=$$LKUP^XUAF4(STN) I STNIEN=0 S XUESSO="-1^"_STN_" WAS NOT FOUND IN FILE 4" Q 
XUESSO
"RTN","XUSBSE1",151,0)
 ; Check if STN is an active facility (security check)
"RTN","XUSBSE1",152,0)
 I '$$ACTIVE^XUAF4(STNIEN) S XUESSO="-1^"_STN_" IS NOT AN ACTIVE VA FACILITY" Q XUESSO
"RTN","XUSBSE1",153,0)
 S IP=""
"RTN","XUSBSE1",154,0)
 ; Look for a valid cached DNS address (less than 1800 seconds old)
"RTN","XUSBSE1",155,0)
 S STNPRNT=$P($$PRNT^XUAF4(STN),U,2) S:'+STNPRNT STNPRNT=STN ; Convert subdivision to parent 
station
"RTN","XUSBSE1",156,0)
 S XUCACHE=$G(^XTMP("XUSBSE1",STNPRNT))
"RTN","XUSBSE1",157,0)
 I ($D(XUCACHE))&($$HDIFF^XLFDT($H,$P(XUCACHE,U,2),2)<1800) S IP=$P(XUCACHE,U,1)
"RTN","XUSBSE1",158,0)
 I '$L(IP) S IP=$$IPFLOC(STNPRNT) ; Get the IP address from  HL LOGICAL LINK file (#870)
"RTN","XUSBSE1",159,0)
 I '$L(IP) S IP=$$SITESVC(STNPRNT) ; Get the IP address from VASITESERVICE
"RTN","XUSBSE1",160,0)
 I '$L(IP) S XUESSO="-1^ADDRESS FOR STN "_STN_" NOT FOUND"
"RTN","XUSBSE1",161,0)
 D:$G(XWBDEBUG) LOG^XWBDLOG("HOME BSE IP: "_IP_" PORT:"_PORT)
"RTN","XUSBSE1",162,0)
 I $L(IP) S XUESSO=$$CALLBSE^XWBTCPM2(IP,PORT,TOKEN,STN)
"RTN","XUSBSE1",163,0)
 D:$G(XWBDEBUG) LOG^XWBDLOG("LEAVING HOME XUESSO: "_XUESSO)
"RTN","XUSBSE1",164,0)
 I XUESSO="Didn't open connection." S XUESSO="-1^COULD NOT CONNECT TO STN "_STN_" USING 
PORT "_PORT
"RTN","XUSBSE1",165,0)
 I XUESSO="No Response" S XUESSO="-1^BSE TOKEN EXPIRED"
"RTN","XUSBSE1",166,0)
 Q XUESSO
"RTN","XUSBSE1",167,0)
 ;
"RTN","XUSBSE1",168,0)
IPFLOC(STN) ;Get the address from the station number from HL LOGICAL LINK file (#870)
"RTN","XUSBSE1",169,0)
 ;   input    STN - station number
"RTN","XUSBSE1",170,0)
 ;   returns      - IP address or null
"RTN","XUSBSE1",171,0)
 N XUSBSE,I,RET,ADD,IP,STNPRNT
"RTN","XUSBSE1",172,0)
 S STNPRNT=$P($$PRNT^XUAF4(STN),U,2) S:'+STNPRNT STNPRNT=STN ; Convert subdivision to parent 
station
"RTN","XUSBSE1",173,0)
 ; Look for station number in HL LOGICAL LINK file (#870)
"RTN","XUSBSE1",174,0)
 D FIND^DIC(870,,".03;.08","X",STNPRNT,,"C",,,"XUSBSE") ; IA# 5449 "C" index lookup
"RTN","XUSBSE1",175,0)
 Q:+$G(XUSBSE("DILIST",0))=0 ""
"RTN","XUSBSE1",176,0)
 S I=0,ADD="",IP=""
"RTN","XUSBSE1",177,0)
 F  S I=$O(XUSBSE("DILIST","ID",I)) Q:'I  D  Q:IP
"RTN","XUSBSE1",178,0)
 . ;HL LOGICAL LINK file (#870) DNS DOMAIN field (#.08)
"RTN","XUSBSE1",179,0)
 . S ADD=XUSBSE("DILIST","ID",I,.08) I $L(ADD) D  Q:IP'=""
"RTN","XUSBSE1",180,0)
 . . I $$VALIDATE^XLFIPV(ADD) S IP=ADD Q  ;ICR #5844
"RTN","XUSBSE1",181,0)
 . . S IP=$$ADDRESS^XLFNSLK(ADD) S:IP="" IP=$$ADDRESS^XLFNSLK(ADD,"A") ; Make 2 attempts to get 
IP, force IPv4 on second attempt
"RTN","XUSBSE1",182,0)
 . . Q
"RTN","XUSBSE1",183,0)
 . ;HL LOGICAL LINK file (#870) MAILMAIN DOMAIN field (#.03)
"RTN","XUSBSE1",184,0)
 . S ADD=XUSBSE("DILIST","ID",I,.03) I $L(ADD) D  Q:IP'=""
"RTN","XUSBSE1",185,0)
 . . I $$VALIDATE^XLFIPV(ADD) S IP=ADD Q  ;ICR #5844
"RTN","XUSBSE1",186,0)
 . . S IP=$$ADDRESS^XLFNSLK("VISTA."_ADD) S:IP="" IP=$$ADDRESS^XLFNSLK("VISTA."_ADD,"A") ; Make 
2 attempts to get IP, force IPv4 on second attempt
"RTN","XUSBSE1",187,0)
 . . Q
"RTN","XUSBSE1",188,0)
 I $L(IP) S ^XTMP("XUSBSE1",STNPRNT)=IP_"^"_$H ; Cache the IP address
"RTN","XUSBSE1",189,0)
 Q IP
"RTN","XUSBSE1",190,0)
 ;
"RTN","XUSBSE1",191,0)
SITESVC(STN) ;Get IP from the stn# from VISTASITESERVICE
"RTN","XUSBSE1",192,0)
 ;   input   STN - station number
"RTN","XUSBSE1",193,0)
 ;   returns     - IP address or null
"RTN","XUSBSE1",194,0)
 N DNSADD,IP,STNPRNT
"RTN","XUSBSE1",195,0)
 S IP=""
"RTN","XUSBSE1",196,0)
 S STNPRNT=$P($$PRNT^XUAF4(STN),U,2) S:'+STNPRNT STNPRNT=STN ; Convert subdivision to parent 
station
"RTN","XUSBSE1",197,0)
 S DNSADD=$$WEBADDRS(STNPRNT)
"RTN","XUSBSE1",198,0)
 I $L(DNSADD) S IP=$$ADDRESS^XLFNSLK(DNSADD) S:IP="" IP=$$ADDRESS^XLFNSLK(DNSADD,"A") ; 
Make 2 attempts to get IP, force IPv4 on second attempt
"RTN","XUSBSE1",199,0)
 I $L(IP) S ^XTMP("XUSBSE1",STNPRNT)=IP_"^"_$H ; Cache the IP address
"RTN","XUSBSE1",200,0)
 Q IP
"RTN","XUSBSE1",201,0)
 ;
"RTN","XUSBSE1",202,0)
WEBADDRS(STNNUM) ;
"RTN","XUSBSE1",203,0)
 N IP,URL,XUSBSE,RESULTS,I,X,POP
"RTN","XUSBSE1",204,0)
 D FIND^DIC(2005.2,,"1","MO","VISTASITESERVICE",,,,,"XUSBSE")
"RTN","XUSBSE1",205,0)
 S URL=$G(XUSBSE("DILIST","ID",1,1))
"RTN","XUSBSE1",206,0)
 D EN1^XUSBSE2(URL_"/getSite?siteID="_STNNUM,.RESULTS)
"RTN","XUSBSE1",207,0)
 S X="" F I=1:1 Q:'$D(RESULTS(I))  I RESULTS(I)["hostname>" S 
X=$P($P(RESULTS(I),"<hostname>",2),"</hostname>") Q
"RTN","XUSBSE1",208,0)
 Q X
"RTN","XUSBSE1",209,0)
 ;
"RTN","XUSBSE1",210,0)
SETUP(XUDEMOG,XUCONTXT) ; Setup user as visitor, add context option
"RTN","XUSBSE1",211,0)
 ;   input XUDEMOG  - string of demographic characteristics
"RTN","XUSBSE1",212,0)
 ;   input XUCONTXT - context option to be given to user
"RTN","XUSBSE1",213,0)
 ; return value = internal entry number for user, or 0
"RTN","XUSBSE1",214,0)
 I '$$PUT^XUESSO1(XUDEMOG) Q 0
"RTN","XUSBSE1",215,0)
 I $G(DUZ)'>0 Q 0
"RTN","XUSBSE1",216,0)
 D SETCNTXT(XUCONTXT)
"RTN","XUSBSE1",217,0)
 Q DUZ
"RTN","XUSBSE1",218,0)
 ;
"RTN","XUSBSE1",219,0)
SETCNTXT(XOPT) ;
"RTN","XUSBSE1",220,0)
 N OPT,XUCONTXT,X
"RTN","XUSBSE1",221,0)
 S XUCONTXT="`"_XOPT
"RTN","XUSBSE1",222,0)
 I $$FIND1^DIC(19,"","X",XUCONTXT)'>0 S X=$$LOGERR("BSE LOGIN ERROR - CONTEXT") Q  ;Context 
option not in option file
"RTN","XUSBSE1",223,0)
 I $G(DUZ("LOA"))=1 H 1
"RTN","XUSBSE1",224,0)
 ;Have to use $D because of screen in 200.03 keeps FIND1^DIC from working.
"RTN","XUSBSE1",225,0)
 I '$D(^VA(200,DUZ,203,"B",XOPT)) D
"RTN","XUSBSE1",226,0)
 . ; Have to give the user a delegated option
"RTN","XUSBSE1",227,0)
 . N XARR S XARR(200.19,"+1,"_DUZ_",",.01)=XUCONTXT
"RTN","XUSBSE1",228,0)
 . D UPDATE^DIE("E","XARR")
"RTN","XUSBSE1",229,0)
 . ; And now she can give himself the context option
"RTN","XUSBSE1",230,0)
 . K XARR S XARR(200.03,"+1,"_DUZ_",",.01)=XUCONTXT
"RTN","XUSBSE1",231,0)
 . D UPDATE^DIE("E","XARR") ; Give context option as a secondary menu item
"RTN","XUSBSE1",232,0)
 . S ^XUTL("XQ",$J,"DUZ(BSE)")=XUCONTXT
"RTN","XUSBSE1",233,0)
 . ; But now we have to remove the delegated option
"RTN","XUSBSE1",234,0)
 . S OPT=$$FIND1^DIC(200.19,","_DUZ_",","X",XUCONTXT)
"RTN","XUSBSE1",235,0)
 . I OPT>0 D
"RTN","XUSBSE1",236,0)
 . . K XARR S XARR(200.19,(OPT_","_DUZ_","),.01)="@"
"RTN","XUSBSE1",237,0)
 . . D FILE^DIE("E","XARR")
"RTN","XUSBSE1",238,0)
 . . Q
"RTN","XUSBSE1",239,0)
 . Q
"RTN","XUSBSE1",240,0)
 Q
"RTN","XUSBSE1",241,0)
 ;
"RTN","XUSBSE1",242,0)
STNTEST ; tests station#-to-IP conversion (IPFLOC,WEBADDRS) used by HOME station#-based callback
"RTN","XUSBSE1",243,0)
 N XUSLSTI,XUSLSTV,XUSSTN,XUSIP1,XUSIP2,XUSBSE
"RTN","XUSBSE1",244,0)
 W !,"Broker Security Enhancement (BSE) Station Number-to-IP conversion test (for BSE"
"RTN","XUSBSE1",245,0)
 W !,"callbacks to home system). Note: It is not necessarily wrong if results differ"
"RTN","XUSBSE1",246,0)
 W !,"or are blank. 2 methods' results are listed: HL LOGICAL LINK/VISTASITESERVICE"
"RTN","XUSBSE1",247,0)
 ;
"RTN","XUSBSE1",248,0)
 D FIND^DIC(2005.2,,"1","MO","VISTASITESERVICE",,,,,"XUSBSE")
"RTN","XUSBSE1",249,0)
 W !!," local VISTASITESERVICE server:",!," ",$G(XUSBSE("DILIST","ID",1,1)),"",!
"RTN","XUSBSE1",250,0)
 K ^TMP($J,"XUSBSE1")
"RTN","XUSBSE1",251,0)
 DO LIST^DIC(4,,"@;.01;11;99;101","IP",,,,"D",,,$NA(^TMP($J,"XUSBSE1")))
"RTN","XUSBSE1",252,0)
 S XUSLSTI=0 F  S XUSLSTI=$O(^TMP($J,"XUSBSE1","DILIST",XUSLSTI)) Q:'+XUSLSTI  D
"RTN","XUSBSE1",253,0)
 . S XUSLSTV=^TMP($J,"XUSBSE1","DILIST",XUSLSTI,0)
"RTN","XUSBSE1",254,0)
 . Q:+$P(XUSLSTV,U,5)
"RTN","XUSBSE1",255,0)
 . S XUSSTN=$P(XUSLSTV,U,4) Q:'$$TF^XUAF4(XUSSTN)
"RTN","XUSBSE1",256,0)
 . S XUSIP1=$$IPFLOC(XUSSTN),XUSIP2=$$SITESVC(XUSSTN)
"RTN","XUSBSE1",257,0)
 . I $L(XUSIP1)!$L(XUSIP2) D
"RTN","XUSBSE1",258,0)
 . . W !,XUSSTN,?8,"(",$P(XUSLSTV,U,2),"): " W 
$S($L(XUSIP1):XUSIP1,1:"blank"),"/",$S($L(XUSIP2):XUSIP2,1:"blank")
"RTN","XUSBSE1",259,0)
 . . I $L(XUSIP1),$L(XUSIP2),(XUSIP1'=XUSIP2) W " ***DIFFERENT***"
"RTN","XUSBSE1",260,0)
 K ^TMP($J,"XUSBSE1")
"RTN","XUSBSE1",261,0)
 Q
"RTN","XUSBSE1",262,0)
LOGERR(XUSETXT) ; log an error in error trap for failed login attempts ; p595
"RTN","XUSBSE1",263,0)
 ; XUSETXT is the error subject line $ZE
"RTN","XUSBSE1",264,0)
 ; The function returns 0 if the error was screened, and 1 if an error was trapped
"RTN","XUSBSE1",265,0)
 N XUSAPP
"RTN","XUSBSE1",266,0)
 ; ZEXCEPT: XWBSEC,XUDEMOG - Kernel global variables
"RTN","XUSBSE1",267,0)
 S XUSAPP=$P($G(DUZ("REMAPP")),U,2)
"RTN","XUSBSE1",268,0)
 I $P($G(XUDEMOG),U,2)="BSE TOKEN EXPIRED" Q 0  ; screen out "TOKEN EXPIRED" errors
"RTN","XUSBSE1",269,0)
 I $G(XWBSEC)="BSE ERROR - BSE TOKEN EXPIRED" Q 0  ; screen out "TOKEN EXPIRED" errors
"RTN","XUSBSE1",270,0)
 I XUSAPP'="" S XUSETXT=XUSETXT_" ("_XUSAPP_")"
"RTN","XUSBSE1",271,0)
 D APPERROR^%ZTER($E(XUSETXT,1,32))
"RTN","XUSBSE1",272,0)
 Q 1
"RTN","XUSBSE1",273,0)
 ;
"RTN","XUSBSE1",274,0)
BSETOKEN(RET,XPHRASE) ; RPC. XUS BSE TOKEN - IA #(under development)
"RTN","XUSBSE1",275,0)
 ;Returns a string that can be passed as the XUBUSRNM parameter to the
"RTN","XUSBSE1",276,0)
 ;XUS SIGNON SETUP rpc to authenticate a user on a remote system. The input
"RTN","XUSBSE1",277,0)
 ;is an application identifier (pass phrase) that, when hashed,
"RTN","XUSBSE1",278,0)
 ;matches the stored hash of an authorized application in the REMOTE
"RTN","XUSBSE1",279,0)
 ;APPLICATION file (#8994.5) APPLICATIONCODE field (#.03)
"RTN","XUSBSE1",280,0)
 ; - Input - Application pass phrase
"RTN","XUSBSE1",281,0)
 N XAPP,XPORT,XSTA,XSTATION,XSTRING,XTOKEN
"RTN","XUSBSE1",282,0)
 S XAPP=$G(XPHRASE)
"RTN","XUSBSE1",283,0)
 I XAPP="" S RET="-1^NOT AUTHENTICATED" Q  ;Application must be authenticated
"RTN","XUSBSE1",284,0)
 S XAPP=$$GETCNTXT^XUESSO2(XPHRASE)
"RTN","XUSBSE1",285,0)
 I +XAPP=-1 S RET="-1^NOT AUTHENTICATED" Q  ;Application must be authenticated
"RTN","XUSBSE1",286,0)
 S XAPP=XPHRASE
"RTN","XUSBSE1",287,0)
 D SETVISIT(.XTOKEN)
"RTN","XUSBSE1",288,0)
 I XTOKEN="-1^NOT AUTHENTICATED" S RET=XTOKEN Q  ;User must be authenticated
"RTN","XUSBSE1",289,0)
 I $G(DUZ(2))="" S RET="-1^HOME STATION NOT IDENTIFIED" Q  ;User must be authenticated on valid 
home station
"RTN","XUSBSE1",290,0)
 S XSTA=$$NS^XUAF4(DUZ(2))
"RTN","XUSBSE1",291,0)
 S XSTATION=$P(XSTA,U,2)
"RTN","XUSBSE1",292,0)
 I XSTA="" S RET="-1^HOME STATION NOT IDENTIFIED" Q  ;User must be authenticated on valid home 
station
"RTN","XUSBSE1",293,0)
 S XPORT=$G(^XTMP("XUSBSE1","RPCBrokerPort"))
"RTN","XUSBSE1",294,0)
 I XPORT="" D
"RTN","XUSBSE1",295,0)
 . ; Do a VistA Exchange Site Service lookup for current station (once daily)
"RTN","XUSBSE1",296,0)
 . N IP,URL,XUSBSE,RESULTS,I,X,POP
"RTN","XUSBSE1",297,0)
 . D FIND^DIC(2005.2,,"1","MO","VISTASITESERVICE",,,,,"XUSBSE")
"RTN","XUSBSE1",298,0)
 . S URL=$G(XUSBSE("DILIST","ID",1,1))
"RTN","XUSBSE1",299,0)
 . D EN1^XUSBSE2(URL_"/getSite?siteID="_XSTATION,.RESULTS)
"RTN","XUSBSE1",300,0)
 . S X="" F I=1:1 Q:'$D(RESULTS(I))  I RESULTS(I)["port>" S X=$P($P(RESULTS(I),"<port>",2),"</port>") Q
"RTN","XUSBSE1",301,0)
 . S XPORT=X
"RTN","XUSBSE1",302,0)
 . I XPORT'="" S ^XTMP("XUSBSE1","RPCBrokerPort")=X
"RTN","XUSBSE1",303,0)
 I XPORT="" S RET="-1^RPC BROKER PORT NOT AVAILABLE" Q  ;Could not obtain port from VistA 
Exchange Site Service lookup
"RTN","XUSBSE1",304,0)
 S XSTRING=XAPP_"^"_XTOKEN_"^"_XSTATION_"^"_XPORT
"RTN","XUSBSE1",305,0)
 S RET="-35^"_$$ENCRYP^XUSRB1(XSTRING)
"RTN","XUSBSE1",306,0)
 Q
"RTN","XUSBSE1",307,0)
 ;
"RTN","XUSHSH")
0^30^B37891600^B31040658
"RTN","XUSHSH",1,0)
XUSHSH ;ISF/STAFF - ENCRYPTION/DECRYPTION UTILITIES ;01/20/16  14:33
"RTN","XUSHSH",2,0)
 ;;8.0;KERNEL;**655,659**;Jul 10, 1995;Build 22
"RTN","XUSHSH",3,0)
 ;Per VA Directive 6402, this routine should not be modified.
"RTN","XUSHSH",4,0)
 ;
"RTN","XUSHSH",5,0)
 ;ZEXCEPT: X ;Returned global value when called as an extrinsic subroutine.
"RTN","XUSHSH",6,0)
 S X=$$EN(X)
"RTN","XUSHSH",7,0)
 Q
"RTN","XUSHSH",8,0)
 ;
"RTN","XUSHSH",9,0)
EN(X) ;Extrinsic function $$EN^XUSHSH(X), IA #4758
"RTN","XUSHSH",10,0)
 N XUA,XUI,XUJ,XUL,XUR,XUX,XUY,XUY1,XUZ D KE Q X
"RTN","XUSHSH",11,0)
 ;
"RTN","XUSHSH",12,0)
KE ;Intrinsic subroutine.
"RTN","XUSHSH",13,0)
 Q:X=""  S XUX=$E(X,1,20),X="",XUL=$L(XUX) D CL F XUZ=1:1 Q:$L(X)>19  D C S 
X=$S(XUZ#2:XUX_X,1:X_XUX)
"RTN","XUSHSH",14,0)
 S X=$E(X,1,20)
"RTN","XUSHSH",15,0)
 S X=$TR(X,$C(127,128))
"RTN","XUSHSH",16,0)
 Q
"RTN","XUSHSH",17,0)
 ;
"RTN","XUSHSH",18,0)
B ;Intrinsic subroutine.
"RTN","XUSHSH",19,0)
 ;ZEXCEPT: X ;Extrinsic global value
"RTN","XUSHSH",20,0)
 ;ZEXCEPT: XUI,XUJ ;Intrinsic global values
"RTN","XUSHSH",21,0)
 F XUI=0:0 Q:X'[$C(127)  S XUJ=$F(X,$C(127)),X=$E(X,1,XUJ-2)_$E(X,XUJ,20)
"RTN","XUSHSH",22,0)
 F XUI=0:0 Q:X'[$C(128)  S XUJ=$F(X,$C(128)),X=$E(X,1,XUJ-2)_$E(X,XUJ,20)
"RTN","XUSHSH",23,0)
 Q
"RTN","XUSHSH",24,0)
 ;
"RTN","XUSHSH",25,0)
C ;Intrinsic subroutine.
"RTN","XUSHSH",26,0)
 ;ZEXCEPT: XUA,XUI,XUJ,XUL,XUR,XUX,XUY,XUY1 ;Intrinsic global values
"RTN","XUSHSH",27,0)
 S XUR=0 F XUI=1:1:XUL S XUR=XUR+$A(XUX,XUI)
"RTN","XUSHSH",28,0)
 S XUR=XUR#94
"RTN","XUSHSH",29,0)
 F XUI=1:1:XUL S XUJ=$F(XUA(XUI),$E(XUX,XUI))-
1+XUR\2,XUA(XUI)=$E(XUA(XUI),XUJ,999)_$E(XUA(XUI),1,XUJ-1)
"RTN","XUSHSH",30,0)
 S XUY="" F XUI=1:1:XUL S XUY1=$F(XUA(XUI#XUL+1),$E(XUX,XUI))+33 S:XUY1=94 XUY1=-1 S 
XUY=XUY_$C(XUY1)
"RTN","XUSHSH",31,0)
 S XUX=XUY Q
"RTN","XUSHSH",32,0)
 ;
"RTN","XUSHSH",33,0)
CL ;Intrinsic subroutine.
"RTN","XUSHSH",34,0)
 F XUI=1:1:XUL S XUA(XUI)=$P($T(Z+$A($E(XUX,XUI))+XUI#20+1),";",3,9)
"RTN","XUSHSH",35,0)
 Q
"RTN","XUSHSH",36,0)
 ;
"RTN","XUSHSH",37,0)
SHAHASH(N,X,FLAG) ;One-Way Hash Utility, IA #6189
"RTN","XUSHSH",38,0)
 ;Input:       N = Length in bits of the desired hash.
"RTN","XUSHSH",39,0)
 ;                  160 (SHA-1)
"RTN","XUSHSH",40,0)
 ;                  224 (SHA-224)
"RTN","XUSHSH",41,0)
 ;                  256 (SHA-256)
"RTN","XUSHSH",42,0)
 ;                  384 (SHA-384)
"RTN","XUSHSH",43,0)
 ;                  512 (SHA-512)
"RTN","XUSHSH",44,0)
 ;             X = String to be hashed.
"RTN","XUSHSH",45,0)
 ;          FLAG = (Optional) Flag to control format of hash:
"RTN","XUSHSH",46,0)
 ;                    "H" - Hexadecimal (default)
"RTN","XUSHSH",47,0)
 ;                    "B" - Base64 Encoded
"RTN","XUSHSH",48,0)
 ;Return: String = Hashed value of X.
"RTN","XUSHSH",49,0)
 ;ZEXCEPT: Encryption,SHAHash
"RTN","XUSHSH",50,0)
 N I,Y,Z,XOUT
"RTN","XUSHSH",51,0)
 I ('$D(N))!('$D(X)) Q ""
"RTN","XUSHSH",52,0)
 I ($G(N)'=160)&($G(N)'=224)&($G(N)'=256)&($G(N)'=384)&($G(N)'=512) Q ""
"RTN","XUSHSH",53,0)
 S XOUT="",Y=$SYSTEM.Encryption.SHAHash(N,X)
"RTN","XUSHSH",54,0)
 I $G(FLAG)="B" D
"RTN","XUSHSH",55,0)
 . S XOUT=$$B64ENCD(Y)
"RTN","XUSHSH",56,0)
 E  D
"RTN","XUSHSH",57,0)
 . F I=1:1 D  Q:Z=-1
"RTN","XUSHSH",58,0)
 . . S Z=$A(Y,I) Q:Z=-1
"RTN","XUSHSH",59,0)
 . . S XOUT=XOUT_$$RJ^XLFSTR($$CNV^XLFUTL(Z,16),2,"0")
"RTN","XUSHSH",60,0)
 Q XOUT
"RTN","XUSHSH",61,0)
 ;
"RTN","XUSHSH",62,0)
B64ENCD(X) ;Base 64 Encode, IA #6189
"RTN","XUSHSH",63,0)
 ;Use with $$B64DECD
"RTN","XUSHSH",64,0)
 ;Input:       X = String to be encoded.
"RTN","XUSHSH",65,0)
 ;Return: String = Encoded value of X.
"RTN","XUSHSH",66,0)
 ;ZEXCEPT: Encryption,Base64Encode
"RTN","XUSHSH",67,0)
 Q $SYSTEM.Encryption.Base64Encode(X)
"RTN","XUSHSH",68,0)
 ;
"RTN","XUSHSH",69,0)
B64DECD(X) ;Base 64 Decode, IA #6189
"RTN","XUSHSH",70,0)
 ;Use with $$B64ENCD
"RTN","XUSHSH",71,0)
 ;Input:       X = String to be decoded.
"RTN","XUSHSH",72,0)
 ;Return: String = Decoded value of X.
"RTN","XUSHSH",73,0)
 ;ZEXCEPT: Encryption,Base64Decode
"RTN","XUSHSH",74,0)
 Q $SYSTEM.Encryption.Base64Decode(X)
"RTN","XUSHSH",75,0)
 ;
"RTN","XUSHSH",76,0)
RSAENCR(TEXT,CERT,CAFILE,CRLFILE,ENC) ;RSA Encrypt, IA #6189
"RTN","XUSHSH",77,0)
 ;Use with $$RSADECR
"RTN","XUSHSH",78,0)
 ;Input:    TEXT = Plaintext string to be encrypted.
"RTN","XUSHSH",79,0)
 ;          CERT = An X.509 certificate containing the RSA public key to be used for encryption,
"RTN","XUSHSH",80,0)
 ;                 in PEM encoded or binary DER format. Note that the length of the plaintext can
"RTN","XUSHSH",81,0)
 ;                 not be greater than the length of the modulus of the RSA public key contained
"RTN","XUSHSH",82,0)
 ;                 in the certificate minus 42 bytes.
"RTN","XUSHSH",83,0)
 ;        CAFILE = The name of a file containing trusted Certificate Authority X.509 Certificates
"RTN","XUSHSH",84,0)
 ;                 in PEM-encoded format, one of which was used to sign the Certificate (optional).
"RTN","XUSHSH",85,0)
 ;       CRLFILE = The name of a file containing X.509 Certificate Revocation Lists in PEM-encoded
"RTN","XUSHSH",86,0)
 ;                 format that should be checked to verify the status of the Certificate (optional).
"RTN","XUSHSH",87,0)
 ;           ENC = Encoding - PKCS #1 v2.1 encoding method (optional):
"RTN","XUSHSH",88,0)
 ;                            1 = OAEP (default)
"RTN","XUSHSH",89,0)
 ;                            2 = PKCS1-v1_5
"RTN","XUSHSH",90,0)
 ;Return: String = Ciphertext.
"RTN","XUSHSH",91,0)
 ;ZEXCEPT: Encryption,RSAEncrypt
"RTN","XUSHSH",92,0)
 I ('$D(TEXT))!('$D(CERT)) Q ""
"RTN","XUSHSH",93,0)
 I $G(ENC)'=2 S ENC=1
"RTN","XUSHSH",94,0)
 Q $SYSTEM.Encryption.RSAEncrypt(TEXT,CERT,$G(CAFILE),$G(CRLFILE),ENC)
"RTN","XUSHSH",95,0)
 ;
"RTN","XUSHSH",96,0)
RSADECR(TEXT,KEY,PWD,ENC) ;RSA Decrypt, IA #6189
"RTN","XUSHSH",97,0)
 ;Use with $$RSAENCR
"RTN","XUSHSH",98,0)
 ;Input:    TEXT = Ciphertext string to be decrypted.
"RTN","XUSHSH",99,0)
 ;           KEY = RSA private key corresponding to the RSA public key that was used for
"RTN","XUSHSH",100,0)
 ;                 encryption, PEM encoded.
"RTN","XUSHSH",101,0)
 ;           PWD = Private key password (optional).
"RTN","XUSHSH",102,0)
 ;           ENC = Encoding - PKCS #1 v2.1 encoding method (optional):
"RTN","XUSHSH",103,0)
 ;                            1 = OAEP (default)
"RTN","XUSHSH",104,0)
 ;                            2 = PKCS1-v1_5
"RTN","XUSHSH",105,0)
 ;Return: String = Plaintext.
"RTN","XUSHSH",106,0)
 ;ZEXCEPT: Encryption,RSADecrypt
"RTN","XUSHSH",107,0)
 I ('$D(TEXT))!('$D(KEY)) Q ""
"RTN","XUSHSH",108,0)
 I $G(ENC)'=2 S ENC=1
"RTN","XUSHSH",109,0)
 Q $SYSTEM.Encryption.RSADecrypt(TEXT,KEY,$G(PWD),ENC)
"RTN","XUSHSH",110,0)
 ;
"RTN","XUSHSH",111,0)
AESENCR(TEXT,KEY,IV) ;AES Encrypt, IA #6189
"RTN","XUSHSH",112,0)
 ;Use with $$EASDECR
"RTN","XUSHSH",113,0)
 ;Input:    TEXT = Plaintext string to be encrypted.
"RTN","XUSHSH",114,0)
 ;           KEY = Input key material 16, 24, or 32 characters long.
"RTN","XUSHSH",115,0)
 ;            IV = Initialization vector (optional). If this argument is present it must be 16 characters long.
"RTN","XUSHSH",116,0)
 ;Return: String = Ciphertext.
"RTN","XUSHSH",117,0)
 ;ZEXCEPT: Encryption,AESCBCEncrypt
"RTN","XUSHSH",118,0)
 I ('$D(TEXT))!('$D(KEY)) Q ""
"RTN","XUSHSH",119,0)
 Q $SYSTEM.Encryption.AESCBCEncrypt(TEXT,KEY,$G(IV))
"RTN","XUSHSH",120,0)
 ;
"RTN","XUSHSH",121,0)
AESDECR(TEXT,KEY,IV) ;AES Decrypt, IA #6189
"RTN","XUSHSH",122,0)
 ;Use with $$EASENCR
"RTN","XUSHSH",123,0)
 ;Input:    TEXT = Ciphertext string to be decrypted.
"RTN","XUSHSH",124,0)
 ;           KEY = Input key material 16, 24, or 32 characters long.
"RTN","XUSHSH",125,0)
 ;            IV = Initialization vector (optional). If this argument is present it must be 16 characters long.
"RTN","XUSHSH",126,0)
 ;Return: String = Plaintext.
"RTN","XUSHSH",127,0)
 ;ZEXCEPT: Encryption,AESCBCDecrypt
"RTN","XUSHSH",128,0)
 I ('$D(TEXT))!('$D(KEY)) Q ""
"RTN","XUSHSH",129,0)
 Q $SYSTEM.Encryption.AESCBCDecrypt(TEXT,KEY,$G(IV))
"RTN","XUSHSH",130,0)
 ;
"RTN","XUSHSH",131,0)
Z ;;
"RTN","XUSHSH",132,0)
 ;;&Qu9l) Jjk|1O+NpA=3*Lbv[(XF,zZWHgi>S"UM;0@.dIon}4_Pw-
8qyC?K/YV6t7sE]f~x'D`TB%R#a{\!G<2$h5rc:me
"RTN","XUSHSH",133,0)
 ;;-tFWg@0D[T2{MZLb/o8y.Jp3Oh7w:knRmqV~Xu#E]GYC+'!rP(4|ScBU"Nv*}z&da6j<e$H,xKA9\; 
s>?%`51I=il_fQ)
"RTN","XUSHSH",134,0)
 ;;1ZsHoTnY;av~%0O+hX,gx[?qCFA/:6{V7|y*f}]258)4GUNl-Q_@r#cPW>$w 
kB3D"K(iLJ=!E'S<MRe&p.mjI\d`u9tzb
"RTN","XUSHSH",135,0)
 ;;J02b7|*p>`WlOm6qI1Q\Me&)i.ETGwH"RLVu{oBv=P?8+X-
j%A!(<]Z,gkh4FDc$}K9n5YC#af;x3/Uty~_N@'rS[sz: d
"RTN","XUSHSH",136,0)
 ;;>uKF}QpBl;~A2DVO=eY</Em&onT.j#+,058"a$k!WN:7LM@\hGv]-3_41`'*y?UPwCZX% 
xIq{(fti)r9HSgRJb6cd|sz[
"RTN","XUSHSH",137,0)
 ;;]z>}GUqT.K4ePp#;Msf"FHc8[J$I2%Sx-~3EurkgBV?\*iW|&_@=YZ 
5b7/<9,`0:NyRaQlhv)X1Do6'({!mLjAtCO+nwd
"RTN","XUSHSH",138,0)
 
;;6Bv>kYgj_GJFE`q]!H27usXz5ZxR%p.Kh{)tUe:~=LV@/[Sw1<Ob$#,8daoT\4cri?Al+Nn3IPmMy9*0"QW|'Cf
D&;}- (
"RTN","XUSHSH",139,0)
 ;;_}+Fkea1<Z,SDh~ `Y62BHuN-
JqO>5j(xsl3*!{G"T&M[/wW4PpiCLtUI9bm:r%fRV.@dQE0A]c\$o|y7;8g?)#=Kz'vnX
"RTN","XUSHSH",140,0)
 ;;TZlp]~x%8,E.}|kMH9/!3a z`yWed0Ccm\jB#SgOfIJ&_(6s{K"@L);>P5<uYD2+nvVRb:'$?XNioqA17-
rU=wFt*Gh[4Q
"RTN","XUSHSH",141,0)
 ;;{.= Kt&vz8_`D;+BYc-
GkQ"[gJd|]oInwyT'l>)e:XN3UVahiS0!9PqE$L?HA4,R/Mm2W~<*6pjrF#@uZ}5%7xbs(Of1\C
"RTN","XUSHSH",142,0)
 ;;f6\W:mYiF.$"hR<XqE4_sdk-3T,yO#Ix}`r'n 
/C)tp9{=NBljLKgvuc[P&!>]VU~20zD+1A5H8%SGQ?@*(Zb|o7JM;aew
"RTN","XUSHSH",143,0)
 ;;]'x[m!8OPYLQosE tw{$HuZv"*Gh;7N2.D~Ji3<%e)@a0fBU&dCR1A+=Mn\p|jzTyK`#/S_br:-
V>FI96,}cq4l5?WXgk(
"RTN","XUSHSH",144,0)
 ;;A{;0d/H$jg.Niy!:'tcah`&z\*"GTeO=MFI~Z5vbu>m_9)C}6Ps73%x]w[?Xrf+QKRqWB|<4EY8DSn1kL oV-
@2#lU(Jp,
"RTN","XUSHSH",145,0)
 ;;Aot4N!@'r/{Rk_<EC"B8l +6)YFz?ID:evMJ[SpZXPs9>f0\caKwU]%*y}GH,m7QdhT&b1V~-
L5Ogx|qju=$`32(.Win;#
"RTN","XUSHSH",146,0)
 ;;-xZ\h3_$9.7f>Be!*sT 
w"UAJ4{q[0mybrENS<dP&]~2i8Ia'MjcKYu;:Rn=G/)t?1W+#%5Q|l(v6pFO`D@V,oCkgzX}LH
"RTN","XUSHSH",147,0)
 ;;mkU3n g/96z>Hx`C"fl5e#uw}Krj7_o*J+vbNR)h\XyOVZ@tE{QTM|]8;c?$PaBW:40,1dY%FG!L[i~D(A.2p=-
S'&<sqI
"RTN","XUSHSH",148,0)
 ;;pnRq(hW1)`Xt7D=9PaT*8<d+3/vIEQrcb-gBjYH]MSU#Nwis5.om_%Cu>}6~x{;|!FA\y 
ekKl,O&['?VG0:2@LZ$fJ4"z
"RTN","XUSHSH",149,0)
 ;;RJfF>=}:0@(8tW-Aid6h*{/,)ON_B"MZHo.?I]Eek<yL5v3$`c[x~74aYqnDuz1bp+\2smlVCQSP#G&j;X9r%g' 
w!|TKU
"RTN","XUSHSH",150,0)
 ;;o*B~e]p0lRY[=/`7CnfO'Wb2+sd3a,6#k{&LU(".qMNG$A%mg:J?Dwc!x5XvS;yj4t<uP@h_KT98 }\H1ZQ-
rFi|I)>zVE
"RTN","XUSHSH",151,0)
 ;;E7UvoK3Z%-y$2]s?}mBLQ!OVN'd58&+rk4;_ 
>u#/1PIt@<~x[G`WA"CMiq|pj=,:a)glXJn0RbwFfDz*e(\H9hc6.{TSY
"RTN","XUSHSH",152,0)
 ;;
"RTN","XUSKAAJ")
0^28^B11718164^B11629985
"RTN","XUSKAAJ",1,0)
XUSKAAJ ;;12/15/15  08:54;08/24/2006
"RTN","XUSKAAJ",2,0)
 ;;8.0;KERNEL;**329,430,659**;Jul 10, 1995;Build 22
"RTN","XUSKAAJ",3,0)
 ;Per VA Directive 6402, this routine should not be modified.
"RTN","XUSKAAJ",4,0)
 ;;
"RTN","XUSKAAJ",5,0)
 QUIT
"RTN","XUSKAAJ",6,0)
 ;
"RTN","XUSKAAJ",7,0)
 ; ------------------------------------------------------------------------
"RTN","XUSKAAJ",8,0)
 ;   SSO/UC KAAJEE RPCs
"RTN","XUSKAAJ",9,0)
 ; ------------------------------------------------------------------------
"RTN","XUSKAAJ",10,0)
 ;
"RTN","XUSKAAJ",11,0)
USERINFO(RET,CLIENTIP,SERVERNM) ; called by XUS KAAJEE GET USER INFO rpc
"RTN","XUSKAAJ",12,0)
 ;
"RTN","XUSKAAJ",13,0)
 ; INPUT:
"RTN","XUSKAAJ",14,0)
 ; CLIENTIP is IP address of the client workstation, used for logging (signon log) and IP blocking (failed 
access attempts).
"RTN","XUSKAAJ",15,0)
 ; SERVERNM is Identifying name for the calling application or server, used for logging (signon log).
"RTN","XUSKAAJ",16,0)
 ; OUTPUT:
"RTN","XUSKAAJ",17,0)
 ; Result(0) is the users DUZ.
"RTN","XUSKAAJ",18,0)
 ; Result(1) is the user name from the .01 field.
"RTN","XUSKAAJ",19,0)
 ; Result(2) is the users full name from the name standard file.
"RTN","XUSKAAJ",20,0)
 ; Result(3) is the FAMILY (LAST) NAME
"RTN","XUSKAAJ",21,0)
 ; Result(4) is the GIVEN (FIRST) NAME
"RTN","XUSKAAJ",22,0)
 ; Result(5) is the MIDDLE NAME
"RTN","XUSKAAJ",23,0)
 ; Result(6) is the PREFIX
"RTN","XUSKAAJ",24,0)
 ; Result(7) is the SUFFIX
"RTN","XUSKAAJ",25,0)
 ; Result(8) is the DEGREE
"RTN","XUSKAAJ",26,0)
 ; Result(9) is station # of the division that the user is working in.
"RTN","XUSKAAJ",27,0)
 ; Result(10) is the station # of the parent facility for the login division
"RTN","XUSKAAJ",28,0)
 ; Result(11) is the station # from the KSP site parameters, the parent "computer system"
"RTN","XUSKAAJ",29,0)
 ; Result(12) is the signon log entry IEN
"RTN","XUSKAAJ",30,0)
 ; Result(13) = # of permissible divisions
"RTN","XUSKAAJ",31,0)
 ; Result(14-n) are the permissible divisions for user login, in the format:
"RTN","XUSKAAJ",32,0)
 ;           IEN of file 4^Station Name^Station Number^default? (1 or 0)
"RTN","XUSKAAJ",33,0)
 ;
"RTN","XUSKAAJ",34,0)
 N I,XUNC,XUNC1,XUKERR,XUKRET,XUDIVS,XUKI,XULINE,XUPARENT,XUDIVLIN,XUKDEF
"RTN","XUSKAAJ",35,0)
 ;
"RTN","XUSKAAJ",36,0)
 ; initialize return array
"RTN","XUSKAAJ",37,0)
 S RET(0)=DUZ
"RTN","XUSKAAJ",38,0)
 F I=1:1:13 S RET(I)=""
"RTN","XUSKAAJ",39,0)
 ;
"RTN","XUSKAAJ",40,0)
 ; get ptr to Name Components file
"RTN","XUSKAAJ",41,0)
 D GETS^DIQ(200,DUZ_",","10.1","I","XUNC","XUKERR")
"RTN","XUSKAAJ",42,0)
 I '$D(XUKERR) D
"RTN","XUSKAAJ",43,0)
 .S XUNC=XUNC(200,DUZ_",",10.1,"I")
"RTN","XUSKAAJ",44,0)
 .; get name components
"RTN","XUSKAAJ",45,0)
 .D GETS^DIQ(20,XUNC_",","1:6","","XUNC1","XUKERR")
"RTN","XUSKAAJ",46,0)
 .I '$D(XUKERR) D
"RTN","XUSKAAJ",47,0)
 ..S RET(3)=XUNC1(20,XUNC_",",1) S:'$L(RET(3)) RET(3)="^"
"RTN","XUSKAAJ",48,0)
 ..S RET(4)=XUNC1(20,XUNC_",",2) S:'$L(RET(4)) RET(4)="^"
"RTN","XUSKAAJ",49,0)
 ..S RET(5)=XUNC1(20,XUNC_",",3) S:'$L(RET(5)) RET(5)="^"
"RTN","XUSKAAJ",50,0)
 ..S RET(6)=XUNC1(20,XUNC_",",4) S:'$L(RET(6)) RET(6)="^"
"RTN","XUSKAAJ",51,0)
 ..S RET(7)=XUNC1(20,XUNC_",",5) S:'$L(RET(7)) RET(7)="^"
"RTN","XUSKAAJ",52,0)
 ..S RET(8)=XUNC1(20,XUNC_",",6) S:'$L(RET(8)) RET(8)="^"
"RTN","XUSKAAJ",53,0)
 ;
"RTN","XUSKAAJ",54,0)
 ; get .01 New Person name, Name components name, and login division info
"RTN","XUSKAAJ",55,0)
 D USERINFO^XUSRB2(.XUKRET)
"RTN","XUSKAAJ",56,0)
 S RET(1)=XUKRET(1) S:'$L(RET(1)) RET(1)="^"
"RTN","XUSKAAJ",57,0)
 S RET(2)=XUKRET(2) S:'$L(RET(2)) RET(2)="^"
"RTN","XUSKAAJ",58,0)
 S RET(9)=$P(XUKRET(3),U,3) S:'$L(RET(9)) RET(9)="0"
"RTN","XUSKAAJ",59,0)
 ;
"RTN","XUSKAAJ",60,0)
 ; get parent facility station#
"RTN","XUSKAAJ",61,0)
 S XUPARENT=$$PRNT^XUAF4(RET(9))
"RTN","XUSKAAJ",62,0)
 S RET(10)=$S(($P(XUPARENT,U)<1):XUPARENT,1:$$STA^XUAF4($P(XUPARENT,U)))
"RTN","XUSKAAJ",63,0)
 S:'$L(RET(10)) RET(10)="^"
"RTN","XUSKAAJ",64,0)
 ;
"RTN","XUSKAAJ",65,0)
 ; get the computer system station#
"RTN","XUSKAAJ",66,0)
 S RET(11)=$$STA^XUAF4($$KSP^XUPARAM("INST"))
"RTN","XUSKAAJ",67,0)
 S:'$L(RET(11)) RET(11)="0"
"RTN","XUSKAAJ",68,0)
 ;
"RTN","XUSKAAJ",69,0)
 ; make signon log entry, get IEN
"RTN","XUSKAAJ",70,0)
 S RET(12)=$$SIGNLOG^XUSKAAJ(CLIENTIP,SERVERNM)
"RTN","XUSKAAJ",71,0)
 ;
"RTN","XUSKAAJ",72,0)
 ; get permitted divisions
"RTN","XUSKAAJ",73,0)
 S XUDIVLIN=13 ; return array subscript counter for division start point
"RTN","XUSKAAJ",74,0)
 D DIVGET^XUSRB2(.XUDIVS,DUZ)
"RTN","XUSKAAJ",75,0)
 I '+XUDIVS(0) S RET(XUDIVLIN)=1,RET(XUDIVLIN+1)=XUKRET(3)_"^1" ; only 1 division, so use login 
division.
"RTN","XUSKAAJ",76,0)
 I +XUDIVS(0) S RET(XUDIVLIN)=+XUDIVS(0) D
"RTN","XUSKAAJ",77,0)
 .S XUKDEF=$O(^VA(200,DUZ,2,"AX1",1,"")) ; default division if any. Should only be 1.
"RTN","XUSKAAJ",78,0)
 .S XUKI=0,XULINE=XUDIVLIN F  S XUKI=$O(XUDIVS(XUKI)) Q:XUKI']""  D
"RTN","XUSKAAJ",79,0)
 ..S XULINE=XULINE+1,RET(XULINE)=XUDIVS(XUKI)
"RTN","XUSKAAJ",80,0)
 ..S $P(RET(XULINE),U,4)=$S($P(XUDIVS(XUKI),U)=XUKDEF:1,1:0)
"RTN","XUSKAAJ",81,0)
 ;
"RTN","XUSKAAJ",82,0)
 Q
"RTN","XUSKAAJ",83,0)
 ;
"RTN","XUSKAAJ",84,0)
SIGNOFF(RET,DA) ; kill entry in sign-on log. Called by XUS KAAJEE LOGOUT rpc.
"RTN","XUSKAAJ",85,0)
 D LOUT^XUSCLEAN(DA)
"RTN","XUSKAAJ",86,0)
 S RET=1 Q
"RTN","XUSKAAJ",87,0)
 ;
"RTN","XUSKAAJ",88,0)
SIGNLOG(CLIENTIP,SERVERNM) ; make a signon log entry for KAAJEE user
"RTN","XUSKAAJ",89,0)
 ; todo: expand size of server name field?
"RTN","XUSKAAJ",90,0)
 N XP1,XPIP,XPCLNM,Y
"RTN","XUSKAAJ",91,0)
 S:$D(IO("IP")) XPIP=IO("IP") S IO("IP")=CLIENTIP
"RTN","XUSKAAJ",92,0)
 S:$D(IO("CLNM")) XPCLNM=IO("CLNM") S IO("CLNM")=$E(SERVERNM,1,20)
"RTN","XUSKAAJ",93,0)
 ;
"RTN","XUSKAAJ",94,0)
 D GETENV^%ZOSV
"RTN","XUSKAAJ",95,0)
 S XP1=$$SLOG^XUS1($P(Y,U,2),,,$P(Y,U),$P(Y,U,3),"KAAJEE","")
"RTN","XUSKAAJ",96,0)
 ;
"RTN","XUSKAAJ",97,0)
 S:$D(XPIP) IO("IP")=XPIP
"RTN","XUSKAAJ",98,0)
 S:$D(XPCLNM) IO("CLNM")=XPCLNM
"RTN","XUSKAAJ",99,0)
 Q XP1
"RTN","XUSKAAJ",100,0)
 ;
"RTN","XUSKAAJ1")
0^29^B2125056^B1687417
"RTN","XUSKAAJ1",1,0)
XUSKAAJ1 ;;12/15/15  08:54;10/19/2009
"RTN","XUSKAAJ1",2,0)
 ;;8.0;KERNEL;**504,659**;Jul 10, 1995;Build 22
"RTN","XUSKAAJ1",3,0)
 ;Per VA Directive 6402, this routine should not be modified.
"RTN","XUSKAAJ1",4,0)
 ;;
"RTN","XUSKAAJ1",5,0)
 QUIT
"RTN","XUSKAAJ1",6,0)
 ;
"RTN","XUSKAAJ1",7,0)
 ; ------------------------------------------------------------------------
"RTN","XUSKAAJ1",8,0)
 ;   SSO/UC KAAJEE RPCs
"RTN","XUSKAAJ1",9,0)
 ; ------------------------------------------------------------------------
"RTN","XUSKAAJ1",10,0)
 ;
"RTN","XUSKAAJ1",11,0)
CCOWIP(RET,CLIENTIP) ;rpc. CCOW Auto Signon Handle for middle tiered application servers
"RTN","XUSKAAJ1",12,0)
 N XUIOIP,XULOOPIP
"RTN","XUSKAAJ1",13,0)
 S XUIOIP=$G(IO("IP")) ; save original
"RTN","XUSKAAJ1",14,0)
 ; get actual ip address instead of localhost address if possible
"RTN","XUSKAAJ1",15,0)
 ;S IO("IP")=$S($G(CLIENTIP)="127.0.0.1":XUIOIP,$G(CLIENTIP)="":XUIOIP,1:$G(CLIENTIP))
"RTN","XUSKAAJ1",16,0)
 S XULOOPIP=$$CONVERT^XLFIPV("127.0.0.1")  ;p659
"RTN","XUSKAAJ1",17,0)
 S IO("IP")=$S($G(CLIENTIP)=XULOOPIP:XUIOIP,$G(CLIENTIP)="":XUIOIP,1:$G(CLIENTIP))  ;p659
"RTN","XUSKAAJ1",18,0)
 D CCOW^XUSRB4(.RET)
"RTN","XUSKAAJ1",19,0)
 S IO("IP")=XUIOIP ; revert to original
"RTN","XUSKAAJ1",20,0)
 Q
"RTN","XUSKAAJ1",21,0)
 ;
"RTN","XUSKAAJ1",22,0)
USERINFO(RET,CLIENTIP,SERVERNM,CCOWTOK) ; rpc, called by XUS KAAJEE GET USER INFO VIA PROXY
"RTN","XUSKAAJ1",23,0)
 ;
"RTN","XUSKAAJ1",24,0)
 N %,DUZ,XUF,XULOOPIP
"RTN","XUSKAAJ1",25,0)
 S XUF=$G(XUF,0)
"RTN","XUSKAAJ1",26,0)
 S %=$G(IO("IP")) ; save original
"RTN","XUSKAAJ1",27,0)
 ; get actual ip address instead of localhost address if possible
"RTN","XUSKAAJ1",28,0)
 ;S IO("IP")=$S($G(CLIENTIP)="127.0.0.1":%,$G(CLIENTIP)="":%,1:$G(CLIENTIP))
"RTN","XUSKAAJ1",29,0)
 S XULOOPIP=$$CONVERT^XLFIPV("127.0.0.1")  ;p659
"RTN","XUSKAAJ1",30,0)
 S IO("IP")=$S($G(CLIENTIP)=XULOOPIP:%,$G(CLIENTIP)="":%,1:$G(CLIENTIP))  ;p659
"RTN","XUSKAAJ1",31,0)
 S DUZ=$$CHECKAV^XUS($$DECRYP^XUSRB1(CCOWTOK))
"RTN","XUSKAAJ1",32,0)
 S IO("IP")=% ; revert to original
"RTN","XUSKAAJ1",33,0)
 D USERINFO^XUSKAAJ(.RET,CLIENTIP,SERVERNM)
"RTN","XUSKAAJ1",34,0)
 Q
"RTN","XUSKAAJ1",35,0)
 ;
"RTN","XUSRB")
0^8^B35393386^B33401626
"RTN","XUSRB",1,0)
XUSRB ;ISCSF/RWF - Request Broker ;12/01/15  07:54
"RTN","XUSRB",2,0)
 
;;8.0;KERNEL;**11,16,28,32,59,70,82,109,115,165,150,180,213,234,238,265,337,395,404,437,523,659*
*;Jul 10, 1995;Build 22
"RTN","XUSRB",3,0)
 ;Per VA Directive 6402, this routine should not be modified.
"RTN","XUSRB",4,0)
 Q  ;No entry from top
"RTN","XUSRB",5,0)
 ;
"RTN","XUSRB",6,0)
 ;RPC BROKER calls, First parameter is always call-by-reference
"RTN","XUSRB",7,0)
VALIDAV(RET,AVCODE) ;RPC. XUS CVC - IA #6296
"RTN","XUSRB",8,0)
 ;Check a users access
"RTN","XUSRB",9,0)
 ;Return R(0)=DUZ, R(1)=(0=OK, 1,2...=Can't sign-on for some reason)
"RTN","XUSRB",10,0)
 ; R(2)=verify needs changing, R(3)=Message, R(4)=0, R(5)=msg cnt, R(5+n)
"RTN","XUSRB",11,0)
 ; R(R(5)+6)=# div user must select from, R(R(5)+6+n)=div
"RTN","XUSRB",12,0)
 ;
"RTN","XUSRB",13,0)
 N X,XUSER,XUNOW,XUDEV,XUM,XUMSG,%1,VCCH K DUZ
"RTN","XUSRB",14,0)
 S U="^",RET(0)=0,RET(5)=0,XUF=$G(XUF,0),XUM=0,XUMSG=0,XUDEV=0
"RTN","XUSRB",15,0)
 S DUZ=0,DUZ(0)="",VCCH=0 D NOW
"RTN","XUSRB",16,0)
 S XOPT=$$STATE^XWBSEC("XUS XOPT")
"RTN","XUSRB",17,0)
 S XUMSG=$$INHIBIT() I XUMSG S XUM=1 G VAX ;Logon inhibited
"RTN","XUSRB",18,0)
 ;3 Strikes
"RTN","XUSRB",19,0)
 I $$LKCHECK^XUSTZIP($G(IO("IP"))) S XUMSG=7 G VAX ;IP locked
"RTN","XUSRB",20,0)
 ;Check type of sign-on code
"RTN","XUSRB",21,0)
 I $L(AVCODE) D
"RTN","XUSRB",22,0)
 . I $E(AVCODE,1,2)="~1" S DUZ=$$CHKASH^XUSRB4(AVCODE),DUZ("AUTHENTICATION")="ASHTOKEN" 
Q
"RTN","XUSRB",23,0)
 . I $E(AVCODE,1,2)="~2" S 
DUZ=$$CHKCCOW^XUSRB4(AVCODE),DUZ("AUTHENTICATION")="CCOWTOKEN" Q
"RTN","XUSRB",24,0)
 . S DUZ=$$CHECKAV^XUS($$DECRYP^XUSRB1(AVCODE)),DUZ("AUTHENTICATION")="AVCODES"
"RTN","XUSRB",25,0)
 . Q
"RTN","XUSRB",26,0)
 I DUZ'>0,$$FAIL^XUS3 D  G VAX
"RTN","XUSRB",27,0)
 . S XUM=1,XUMSG=7,X=$$RA^XUSTZ H 5 ;3 Strikes
"RTN","XUSRB",28,0)
 S XUMSG=$$UVALID^XUS() G:XUMSG VAX ;Check User
"RTN","XUSRB",29,0)
 S VCCH=$$VCVALID() ;Check VC
"RTN","XUSRB",30,0)
 I $G(DUZ("LOA"))="" S DUZ("LOA")=2
"RTN","XUSRB",31,0)
 I DUZ>0 S XUMSG=$$POST(1)
"RTN","XUSRB",32,0)
 I XUMSG>0 S DUZ=0,VCCH=0 ;If can't sign-on, don't tell need to change VC
"RTN","XUSRB",33,0)
 I 'XUMSG,VCCH S XUMSG=12 D SET^XWBSEC("XUS DUZ",DUZ) ;Need to change VC
"RTN","XUSRB",34,0)
VAX S:XUMSG>0 DUZ=0 ;Can't sign-on, Clear DUZ.
"RTN","XUSRB",35,0)
 I DUZ>0 D
"RTN","XUSRB",36,0)
 . S DUZ("LOA")=2
"RTN","XUSRB",37,0)
 . D POST2
"RTN","XUSRB",38,0)
 S RET(0)=DUZ,RET(1)=XUM,RET(2)=VCCH,RET(3)=$S(XUMSG:$$TXT^XUS3(XUMSG),1:""),RET(4)=0
"RTN","XUSRB",39,0)
 K DUZ("CCOW")
"RTN","XUSRB",40,0)
 Q
"RTN","XUSRB",41,0)
 ;
"RTN","XUSRB",42,0)
NOW S U="^",XUNOW=$$NOW^XLFDT(),DT=$P(XUNOW,".")
"RTN","XUSRB",43,0)
 Q
"RTN","XUSRB",44,0)
 ;
"RTN","XUSRB",45,0)
INTRO(RET) ;Return INTRO TEXT.
"RTN","XUSRB",46,0)
 D INTRO^XUS1A("RET")
"RTN","XUSRB",47,0)
 Q
"RTN","XUSRB",48,0)
 ;
"RTN","XUSRB",49,0)
VCVALID() ;Return 1 if the Verify code needs changing.
"RTN","XUSRB",50,0)
 Q:'$G(DUZ) 1
"RTN","XUSRB",51,0)
 Q:$P($G(^VA(200,DUZ,.1)),U,2)="" 1 ;VC is empty
"RTN","XUSRB",52,0)
 Q:$P(^VA(200,DUZ,0),U,8)=1 0 ;VC never expires
"RTN","XUSRB",53,0)
 N XUSER D USER^XUS(DUZ)
"RTN","XUSRB",54,0)
 Q $$VCHG^XUS1
"RTN","XUSRB",55,0)
 ;
"RTN","XUSRB",56,0)
CVC(RET,XU1) ;change VC, Return 0 = success
"RTN","XUSRB",57,0)
 N XU2,XU3,XU4 S DUZ=$G(DUZ),RET(0)=99,XU4=$$STATE^XWBSEC("XUS DUZ") S:(DUZ=0)&(XU4>0) 
DUZ=XU4 Q:DUZ'>0
"RTN","XUSRB",58,0)
 S U="^",XU2=$P(XU1,U,2),XU3=$P(XU1,U,3),XU1=$P(XU1,U)
"RTN","XUSRB",59,0)
 S XU1=$$DECRYP^XUSRB1(XU1),XU2=$$DECRYP^XUSRB1(XU2),XU3=$$DECRYP^XUSRB1(XU3)
"RTN","XUSRB",60,0)
 S XU3=$$BRCVC^XUS2(XU1,XU2),RET(0)=+XU3,RET(1)=$P(XU3,U,2,9)
"RTN","XUSRB",61,0)
 I XU3>0 S DUZ=0 ;Clean-up if not changed.
"RTN","XUSRB",62,0)
 I 'XU3,XU4 D KILL^XWBSEC("XUS DUZ"),POST2
"RTN","XUSRB",63,0)
 Q
"RTN","XUSRB",64,0)
 ;
"RTN","XUSRB",65,0)
SHOWPOST() ;EF. Check if should send the POST SIGN-ON msg.
"RTN","XUSRB",66,0)
 Q +$P($G(^XTV(8989.3,1,"XWB")),"^",2)
"RTN","XUSRB",67,0)
 ;
"RTN","XUSRB",68,0)
POST(CVC) ;Finish setup partition, I CVC don't log yet
"RTN","XUSRB",69,0)
 N X,XUM,XUDIV S:$D(IO)[0 IO=$I S IO(0)=IO
"RTN","XUSRB",70,0)
 K ^UTILITY($J),^TMP($J)
"RTN","XUSRB",71,0)
 I '$D(XUSER(0)),DUZ D USER^XUS(DUZ)
"RTN","XUSRB",72,0)
 S XUM=$$USER^XUS1A Q:XUM>0 XUM ;User can't sign on for some reason.
"RTN","XUSRB",73,0)
 S RET(5)=0 ;The next line sends the post sign-on msg
"RTN","XUSRB",74,0)
 F %=1:1 Q:'$D(XUTEXT(%))  S RET(5+%)=$E(XUTEXT(%),2,256),RET(5)=%
"RTN","XUSRB",75,0)
 I '$$SHOWPOST S RET(5)=0 ;This line stops the sending/display of the msg.
"RTN","XUSRB",76,0)
 D:'$G(CVC) POST2
"RTN","XUSRB",77,0)
 Q 0
"RTN","XUSRB",78,0)
 ;
"RTN","XUSRB",79,0)
POST2 ;Finish User Setup for silent log-on
"RTN","XUSRB",80,0)
 D:'$D(XUNOW) NOW
"RTN","XUSRB",81,0)
 D DUZ^XUS1A,SAVE^XUS1,LOG^XUS1,ABT^XQ12
"RTN","XUSRB",82,0)
 D KILL^XWBSEC("XUS XOPT"),CLRFAC^XUS3($G(IO("IP"))) ;p265
"RTN","XUSRB",83,0)
 D SETTIME^XWBTCPM() ;Set normal Broker time-out
"RTN","XUSRB",84,0)
 S DTIME=$$DTIME^XUP(DUZ) ;See DTIME set for user
"RTN","XUSRB",85,0)
 K:$G(XWBVER)<1.106 XQY,XQY0 ;Delete the sign-on context.
"RTN","XUSRB",86,0)
 K XUTEXT,XOPT,XUEON,XUEOFF,XUTT,XUDEV,XUSER
"RTN","XUSRB",87,0)
 Q
"RTN","XUSRB",88,0)
 ;
"RTN","XUSRB",89,0)
INHIBIT() ;Is Logon to this system Inhibited?
"RTN","XUSRB",90,0)
 I $$INHIB1() Q 1
"RTN","XUSRB",91,0)
 I $$INHIB2() Q 2
"RTN","XUSRB",92,0)
 Q 0
"RTN","XUSRB",93,0)
 ;
"RTN","XUSRB",94,0)
INHIB1() ;The LOGON check
"RTN","XUSRB",95,0)
 I $G(^%ZIS(14.5,"LOGON",XQVOL)) Q 1
"RTN","XUSRB",96,0)
 Q 0
"RTN","XUSRB",97,0)
 ;
"RTN","XUSRB",98,0)
INHIB2() ;The Max User Check
"RTN","XUSRB",99,0)
 I $D(^%ZOSF("ACTJ")) X ^("ACTJ") I $P(XUVOL,U,3),($P(XUVOL,U,3)'>Y) Q 2
"RTN","XUSRB",100,0)
 Q 0
"RTN","XUSRB",101,0)
 ;
"RTN","XUSRB",102,0)
LOGOUT ;Finish logout of user.
"RTN","XUSRB",103,0)
 N XU1
"RTN","XUSRB",104,0)
 D CLEARALL^XWBDRPC(.XU1)
"RTN","XUSRB",105,0)
 ;Remove CCOW sign-on data
"RTN","XUSRB",106,0)
 S HDL=$G(^XUTL("XQ",$J,"HDL")) I $L(HDL) D
"RTN","XUSRB",107,0)
 . K ^XTMP(HDL,"JOB",$J)
"RTN","XUSRB",108,0)
 . I $O(^XTMP(HDL,"JOB",0))="" K ^XTMP(HDL)
"RTN","XUSRB",109,0)
 ;
"RTN","XUSRB",110,0)
 D BYE^XUSCLEAN,XUTL^XUSCLEAN ;Mark the sign-on log, File cleanup.
"RTN","XUSRB",111,0)
 Q
"RTN","XUSRB",112,0)
 ;D1,D2 are place holders for now
"RTN","XUSRB",113,0)
SETUP(RET,XWBUSRNM,ASOSKIP,D2) ;RPC. XUS SIGNON SETUP - IA #1632 (API IA #4054)
"RTN","XUSRB",114,0)
 ;sets up environment for GUI signon
"RTN","XUSRB",115,0)
 N X1 K DUZ
"RTN","XUSRB",116,0)
 S XWBUSRNM=$G(XWBUSRNM),ASOSKIP=$G(ASOSKIP)
"RTN","XUSRB",117,0)
 I $L($G(XWBTIP)) S IO("IP")=XWBTIP
"RTN","XUSRB",118,0)
 S IO("CLNM")=$$LOW^XLFSTR($G(XWBCLMAN)) D ZIO^%ZIS4
"RTN","XUSRB",119,0)
 ;Setup needed variables
"RTN","XUSRB",120,0)
 D SET1^XUS(0),SET^XWBSEC("XUS XOPT",XOPT) ;p265
"RTN","XUSRB",121,0)
 ;I '$D(IO("HOME")) S %ZIS="0H",IOP="NULL" D ^%ZIS ;Setup NULL as the home device
"RTN","XUSRB",122,0)
 D SAVE^XUS1 ;save the home device
"RTN","XUSRB",123,0)
 ;0=server name, 1=volume, 2=uci, 3=device, 4=# attempts, 5=skip signon-screen,6=Domain Name, 
7=Production (0=no, 1=Yes)
"RTN","XUSRB",124,0)
 S RET(0)=$P(XUENV,U,3),RET(1)=$P(XUVOL,U),RET(2)=XUCI
"RTN","XUSRB",125,0)
 S RET(3)=$I,RET(4)=$P(XOPT,U,2),RET(5)=0
"RTN","XUSRB",126,0)
 S RET(6)=$G(^XMB("NETNAME")) ;DBIA #1131
"RTN","XUSRB",127,0)
 S RET(7)=$$PROD^XUPROD ;Tell if production.
"RTN","XUSRB",128,0)
 S X1=$$INHIBIT() I X1 S XWBERR=$S(X1=1:"Logons Inhibited",1:"Max Users") Q  ;p523
"RTN","XUSRB",129,0)
 ; Check for Broker Security Enhancement (BSE) token
"RTN","XUSRB",130,0)
 I (+XWBUSRNM<-30),$$CHKUSER^XUSBSE1(XWBUSRNM) S RET(5)=1 D POST2 Q  ;p523 BSE CHANGE
"RTN","XUSRB",131,0)
 ; End of Check for BSE token
"RTN","XUSRB",132,0)
 ;Auto sign-on check only for Broker v1.1
"RTN","XUSRB",133,0)
 I $G(ASOSKIP) S XQXFLG("ASO")=1 ;Skip the ASO check, Not for VISITORS p523
"RTN","XUSRB",134,0)
 I $G(XWBVER)<1.1 S XQXFLG("ZEBRA")=-1 ;Disable for v1.0
"RTN","XUSRB",135,0)
 I $L(IO("CLNM")),'$G(DUZ) S DUZ=$$AUTOXWB^XUS1B() ;Only check when 1.1 CL.
"RTN","XUSRB",136,0)
 I $G(DUZ)>0 D  ;p523
"RTN","XUSRB",137,0)
 . I '$D(XUSER(0)),DUZ D USER^XUS(DUZ)
"RTN","XUSRB",138,0)
 . N %T S %T=$$USER^XUS1A I %T S DUZ=0 Q
"RTN","XUSRB",139,0)
 . D NOW,POST2 S RET(5)=1
"RTN","XUSRB",140,0)
 Q
"RTN","XUSRB",141,0)
 ;
"RTN","XUSRB",142,0)
OWNSKEY(RET,LIST,IEN) ;RPC. XUS KEY CHECK - IA #6286 (API IA #3277)
"RTN","XUSRB",143,0)
 ;Does user have Security Key?
"RTN","XUSRB",144,0)
 N I,K S I=""
"RTN","XUSRB",145,0)
 I $G(IEN)'>0 S IEN=$G(DUZ)
"RTN","XUSRB",146,0)
 I $G(IEN)'>0 S RET(0)=0 Q
"RTN","XUSRB",147,0)
 I $O(LIST(""))="" S RET(0)=$$KCHK(LIST,IEN) Q
"RTN","XUSRB",148,0)
 F  S I=$O(LIST(I)) Q:I=""  S RET(I)=$$KCHK(LIST(I),IEN)
"RTN","XUSRB",149,0)
 Q
"RTN","XUSRB",150,0)
 ;
"RTN","XUSRB",151,0)
KCHK(%,IEN) ;Key Check
"RTN","XUSRB",152,0)
 S:$G(IEN)'>0 IEN=$G(DUZ) Q $S($G(IEN)>0:$D(^XUSEC(%,IEN)),1:0)
"RTN","XUSRB",153,0)
 ;
"RTN","XUSRB",154,0)
ALLKEYS(RET,IEN,FLG) ;RPC. XUS ALLKEYS - IA #6287 (API IA #3277)
"RTN","XUSRB",155,0)
 ;Return ALL or most KEYS that a user has.
"RTN","XUSRB",156,0)
 N I,J,K,L K ^TMP("XU",$J)
"RTN","XUSRB",157,0)
 S RET=$NA(^TMP("XU",$J))
"RTN","XUSRB",158,0)
 S:'$D(IEN) IEN=DUZ I IEN'>0 S @RET@(0)=-1 Q
"RTN","XUSRB",159,0)
 S I=0,L=0
"RTN","XUSRB",160,0)
 F  S I=$O(^VA(200,IEN,51,I)) Q:I'>0  S K=$G(^DIC(19.1,I,0)) D
"RTN","XUSRB",161,0)
 . Q:'$P(K,U,5)  ;Check 'Send to J2EE' field.
"RTN","XUSRB",162,0)
 . S L=L+1,@RET@(L,0)=$P(K,U,1)
"RTN","XUSRB",163,0)
 . Q
"RTN","XUSRB",164,0)
 Q
"RTN","XUSRB",165,0)
 ;
"RTN","XUSRB",166,0)
AVHELP(RET) ; send access/verify code instructions.
"RTN","XUSRB",167,0)
 S RET(0)=$$AVHLPTXT^XUS2()
"RTN","XUSRB",168,0)
 Q
"RTN","XUSRB",169,0)
 ;
"RTN","XUSRB",170,0)
OPTACCES(RET,USER,OPTIONS,MODE) ;Checks or sets user's access for passed in options
"RTN","XUSRB",171,0)
 S MODE="CHECK" ;only CHECK mode supported for now
"RTN","XUSRB",172,0)
 N I S I=""
"RTN","XUSRB",173,0)
 I $G(USER)'>0 S RET(0)=0 Q
"RTN","XUSRB",174,0)
 F  S I=$O(OPTIONS(I)) Q:I=""  S RET(I)=$$CHK^XQCS(USER,OPTIONS(I))=1
"RTN","XUSRB",175,0)
 Q
"RTN","XUSRB",176,0)
 ;
"RTN","XUSRB",177,0)
CHECKAV(AVC) ;SR. EF. to check an A/V code, Separate w/ ";", return IEN or 0
"RTN","XUSRB",178,0)
 N XUF,XUSER S XUF=0,U="^"
"RTN","XUSRB",179,0)
 Q $$CHECKAV^XUS(AVC)
"RTN","XUSRB4")
0^21^B20805610^B18435992
"RTN","XUSRB4",1,0)
XUSRB4 ;ISF/RWF - Build a temporary sign-on token ;01/29/14  14:56
"RTN","XUSRB4",2,0)
 ;;8.0;KERNEL;**150,337,395,419,437,499,523,573,596,638,659**;Jul 10, 1995;Build 22
"RTN","XUSRB4",3,0)
 ;Per VA Directive 6402, this routine should not be modified.
"RTN","XUSRB4",4,0)
 Q
"RTN","XUSRB4",5,0)
 ;
"RTN","XUSRB4",6,0)
ASH(RET) ;rpc. Auto Signon Handle
"RTN","XUSRB4",7,0)
 N HDL
"RTN","XUSRB4",8,0)
 ;Do not give token to user with authentication Level Of Assurance = 1, as they then would
"RTN","XUSRB4",9,0)
 ;have the ability to re-authenticate at a higher Level Of Assurance (spoofing).
"RTN","XUSRB4",10,0)
 S RET="NOT AUTHENTICATED"
"RTN","XUSRB4",11,0)
 I $G(DUZ)<1 Q  ;Not an authenticated user
"RTN","XUSRB4",12,0)
 I $G(DUZ("LOA"))=1 Q  ;Not an authenticated user
"RTN","XUSRB4",13,0)
 S HDL=$$HANDLE("XWBAS",1),RET="~1"_HDL
"RTN","XUSRB4",14,0)
 ;Now place user info in it.
"RTN","XUSRB4",15,0)
 D TOK(HDL)
"RTN","XUSRB4",16,0)
 Q
"RTN","XUSRB4",17,0)
 ;
"RTN","XUSRB4",18,0)
CCOW(RET) ;rpc. CCOW Auto Signon Handle
"RTN","XUSRB4",19,0)
 N HDL,HDL2,X
"RTN","XUSRB4",20,0)
 S RET(0)="NO PROXY USER",RET(1)="ERROR"
"RTN","XUSRB4",21,0)
 I $$USERTYPE^XUSAP(DUZ,"APPLICATION PROXY") Q  ;No Proxy
"RTN","XUSRB4",22,0)
 I $$USERTYPE^XUSAP(DUZ,"CONNECTOR PROXY") Q  ;No Proxy
"RTN","XUSRB4",23,0)
 ;Do not give token to user with authentication Level Of Assurance = 1, as they then would
"RTN","XUSRB4",24,0)
 ;have the ability to re-authenticate at a higher Level Of Assurance (spoofing).
"RTN","XUSRB4",25,0)
 S RET(0)="NOT AUTHENTICATED",RET(1)="ERROR"
"RTN","XUSRB4",26,0)
 I $G(DUZ("LOA"))=1 Q  ;Not an authenticated user
"RTN","XUSRB4",27,0)
 S X=$$ACTIVE^XUSER(DUZ) I 'X S RET(0)=X Q  ;User must be active
"RTN","XUSRB4",28,0)
 S HDL=$$HANDLE("XWBCCW",1)
"RTN","XUSRB4",29,0)
 ;Return RET(0) the CCOW token, RET(1) the domain name and the Station #
"RTN","XUSRB4",30,0)
 S RET(0)="~2"_$$LOW^XLFSTR(HDL),RET(1)=$G(^XMB("NETNAME"))_"^"_$$STA^XUAF4(DUZ(2))
"RTN","XUSRB4",31,0)
 ;Now place user info in it.
"RTN","XUSRB4",32,0)
 D TOK(HDL)
"RTN","XUSRB4",33,0)
 S ^XUTL("XQ",$J,"HDL")=HDL ;Save handle with job
"RTN","XUSRB4",34,0)
 Q
"RTN","XUSRB4",35,0)
 ;
"RTN","XUSRB4",36,0)
HANDLE(NS,LT) ;Return a unique handle into ^XTMP (ef. sup)
"RTN","XUSRB4",37,0)
 ;NS is the namespace, LT is the Handle Lifetime in days
"RTN","XUSRB4",38,0)
 N %H,A,J,HL
"RTN","XUSRB4",39,0)
 I $G(NS)="" Q "" ;Return null if no namespace
"RTN","XUSRB4",40,0)
 S LT=$G(LT,1) S:LT>7 LT=7 ;Default to 1
"RTN","XUSRB4",41,0)
 S %H=$H,J=NS_($J#2048)_"-"_(%H#7*86400+$P(%H,",",2))_"_",A=$R(10)
"RTN","XUSRB4",42,0)
 F  S HL=J_A,A=A+1 L +^XTMP(HL):1 I $T Q:'$D(^XTMP(HL))  L -^XTMP(HL)
"RTN","XUSRB4",43,0)
 S ^XTMP(HL,0)=$$HTFM^XLFDT(%H+LT)_"^"_$$DT^XLFDT()
"RTN","XUSRB4",44,0)
 ;L -^XTMP(HL) Leave the Unlock to the caller
"RTN","XUSRB4",45,0)
 Q HL
"RTN","XUSRB4",46,0)
 ;
"RTN","XUSRB4",47,0)
TOK(H) ;Store a Token
"RTN","XUSRB4",48,0)
 ;H is handle into XTMP
"RTN","XUSRB4",49,0)
 N J,T,R,%
"RTN","XUSRB4",50,0)
 S T=$$H3^%ZTM($H)
"RTN","XUSRB4",51,0)
 S R=$J_"|"_T_"|"_$G(DUZ)_"|"_H
"RTN","XUSRB4",52,0)
 S ^XTMP(H,"D",0)="|"_$$ENCRYP^XUSRB1(R)_"|"
"RTN","XUSRB4",53,0)
 S ^XTMP(H,"D2")=$G(DUZ(2))
"RTN","XUSRB4",54,0)
 S %=$G(IO("IP")) I $L(%),'$$VALIDATE^XLFIPV(%) S %=$P($$ADDRESS^XLFNSLK(%),",")  ;p638
"RTN","XUSRB4",55,0)
 S ^XTMP(H,"D3")=%
"RTN","XUSRB4",56,0)
 S ^XTMP(H,"CLNM")=$G(IO("CLNM"))
"RTN","XUSRB4",57,0)
 S ^XTMP(H,"JOB",$J)=$G(IO("IP"))
"RTN","XUSRB4",58,0)
 S ^XTMP(H,"STATUS")="0^New",^("CNT")=0
"RTN","XUSRB4",59,0)
 L -^XTMP(H) ;Clear Lock
"RTN","XUSRB4",60,0)
 Q
"RTN","XUSRB4",61,0)
 ;
"RTN","XUSRB4",62,0)
REMOVE(HL) ;Remove (kill) a Handle. p523
"RTN","XUSRB4",63,0)
 I $L($G(HL)) K ^XTMP(HL)
"RTN","XUSRB4",64,0)
 Q
"RTN","XUSRB4",65,0)
 ;
"RTN","XUSRB4",66,0)
CHKASH(HL) ;rpc. Check a Auto Signon Handle
"RTN","XUSRB4",67,0)
 N HDL,RET,FDA,IEN S HDL=$E(HL,3,999)
"RTN","XUSRB4",68,0)
 S RET=$$CHECK(HDL)
"RTN","XUSRB4",69,0)
 I RET>0 D
"RTN","XUSRB4",70,0)
 . S DUZ("ASH")=1,IEN=DUZ_","
"RTN","XUSRB4",71,0)
 . I $$GET1^DIQ(200,IEN,7,"I") S FDA(200,DUZ_",",7)=0 D FILE^DIE("K","FDA") ;p403
"RTN","XUSRB4",72,0)
 D REMOVE(HDL) ;Token only good for one try.
"RTN","XUSRB4",73,0)
 Q RET
"RTN","XUSRB4",74,0)
 ;
"RTN","XUSRB4",75,0)
CHKCCOW(HL) ;rpc. Check a CCOW Auto Signon Handle
"RTN","XUSRB4",76,0)
 N HDL,RET,T
"RTN","XUSRB4",77,0)
 S HDL=$$UP^XLFSTR($E(HL,3,999)),T=$P($G(^XTV(8989.3,1,30),5400),U)
"RTN","XUSRB4",78,0)
 S RET=$$CHECK(HDL,T)
"RTN","XUSRB4",79,0)
 I RET>0 D
"RTN","XUSRB4",80,0)
 . ;This CCOW Token good for more that one try.
"RTN","XUSRB4",81,0)
 . S ^XTMP(HDL,"JOB",$J)=$G(IO("IP"))
"RTN","XUSRB4",82,0)
 . S ^XTMP(HDL,"STATUS")=(^XTMP(HDL,"STATUS")+1)_"^Active"
"RTN","XUSRB4",83,0)
 . S ^XUTL("XQ",$J,"HDL")=HDL ;Save handle with job
"RTN","XUSRB4",84,0)
 . S DUZ("CCOW")=1 ;Flag a CCOW sign-on.
"RTN","XUSRB4",85,0)
 Q RET
"RTN","XUSRB4",86,0)
 ;
"RTN","XUSRB4",87,0)
CHECK(HL,TOUT) ;Check a Token
"RTN","XUSRB4",88,0)
 N %,J,D,L,M,S,T,CLNM
"RTN","XUSRB4",89,0)
 S S=$G(^XTMP(HL,0)) I '$L(S) Q "0^Bad Handle"
"RTN","XUSRB4",90,0)
 S S=$G(^XTMP(HL,"D",0)) I '$L(S) Q "0^Bad Handle" ;Now have real token
"RTN","XUSRB4",91,0)
 I $E(S)'="|" Q "0^Bad Token"
"RTN","XUSRB4",92,0)
 S S=$$DECRYP^XUSRB1($E(S,2,$L(S)-1)) I S="" Q "0^Bad Token"
"RTN","XUSRB4",93,0)
 S J=$P(S,"|"),T=$P(S,"|",2),D=$P(S,"|",3),M=$P(S,"|",4)
"RTN","XUSRB4",94,0)
 ;Check token time
"RTN","XUSRB4",95,0)
 S %=$$H3^%ZTM($H),TOUT=$G(TOUT,90) ; P573 changed 20 to 90 JLI
"RTN","XUSRB4",96,0)
 I T+TOUT<% D REMOVE(HL) Q "0^Token Expired" ;Token good for TOUT or 90 seconds
"RTN","XUSRB4",97,0)
 ;Check job
"RTN","XUSRB4",98,0)
 ;Check that token has handle
"RTN","XUSRB4",99,0)
 I M'=HL Q "0^Bad Token"
"RTN","XUSRB4",100,0)
 ;Check User
"RTN","XUSRB4",101,0)
 I $G(^VA(200,D,0))="" Q "0^Bad User"
"RTN","XUSRB4",102,0)
 ;Do IP check
"RTN","XUSRB4",103,0)
 S %=$G(IO("IP")),T=0,CLNM=""
"RTN","XUSRB4",104,0)
 I $L(%),'$$VALIDATE^XLFIPV(%) S CLNM=%,%=$P($$ADDRESS^XLFNSLK(%),",")  ;p638
"RTN","XUSRB4",105,0)
 S CLNM=$S($L($G(IO("CLNM"))):IO("CLNM"),$L(CLNM):CLNM,1:"") ;p499
"RTN","XUSRB4",106,0)
 I $L($G(^XTMP(HL,"D3"))),^XTMP(HL,"D3")=% S T=1
"RTN","XUSRB4",107,0)
 I 'T,$L(CLNM),$G(^XTMP(HL,"CLNM"))=IO("CLNM") S T=1
"RTN","XUSRB4",108,0)
 I 'T,$$LOW^XLFSTR($S($L($G(IO("ZIO"))):IO("ZIO"),1:$G(IO)))[$P($G(^XTMP(HL,"CLNM")),".") S T=1  
;ram p596
"RTN","XUSRB4",109,0)
 I 'T Q "0^Different IP" ;p499
"RTN","XUSRB4",110,0)
 I $D(^XTMP(HL,"D2")),D>0 S DUZ(2)=^XTMP(HL,"D2")
"RTN","XUSRB4",111,0)
 D USER^XUS(D)
"RTN","XUSRB4",112,0)
 Q D
"RTN","XUSRB4",113,0)
 ;
"RTN","XUSRB4",114,0)
 ;
"RTN","XUSRB4",115,0)
CCOWPC(RET) ;Return ap
"RTN","XUSRB4",116,0)
 N I,XU4
"RTN","XUSRB4",117,0)
 S RET(0)="" I '$$BROKER^XWBLIB Q
"RTN","XUSRB4",118,0)
 D GETLST^XPAR(.XU4,"SYS","XUS CCOW VAULT PARAM","Q")
"RTN","XUSRB4",119,0)
 F I=0,1 S RET(I)=$P($G(XU4(I+1)),"^",2,99)
"RTN","XUSRB4",120,0)
 Q
"RTN","XUSRB4",121,0)
 ;
"RTN","XUSRB4",122,0)
 ;p500
"RTN","XUSRB4",123,0)
CCOWIP(RET,CLIENTIP) ;rpc. CCOW Auto Signon Handle for middle tiered application servers
"RTN","XUSRB4",124,0)
 N %
"RTN","XUSRB4",125,0)
 S %=$G(IO("IP")) ; save original
"RTN","XUSRB4",126,0)
 ; get actual ip address instead of localhost address if possible
"RTN","XUSRB4",127,0)
 S IO("IP")=$S($G(CLIENTIP)=$$CONVERT^XLFIPV("127.0.0.1"):%,$G(CLIENTIP)="":%,1:$G(CLIENTIP)) 
;p638
"RTN","XUSRB4",128,0)
 D CCOW(.RET)
"RTN","XUSRB4",129,0)
 S IO("IP")=% ; revert to original
"RTN","XUSRB4",130,0)
 Q
"RTN","XUSRB4",131,0)
 ;
"VER")
8.0^22.0
"^DD",3.081,3.081,101,0)
LEVEL OF ASSURANCE^F^^1;2^K:$L(X)>1!($L(X)<1) X
"^DD",3.081,3.081,101,.1)
LOA
"^DD",3.081,3.081,101,3)
Answer must be 1 character in length.
"^DD",3.081,3.081,101,21,0)
^^31^31^3151014^
"^DD",3.081,3.081,101,21,1,0)
Level of Assurance (LOA) of the authenticated user sign-on per guidance 
"^DD",3.081,3.081,101,21,2,0)
from OMB 04-04 and NIST SP 800-63-2.
"^DD",3.081,3.081,101,21,3,0)
 
"^DD",3.081,3.081,101,21,4,0)
LOA=1
"^DD",3.081,3.081,101,21,5,0)
   Little or no confidence exists in the asserted identity; usually 
"^DD",3.081,3.081,101,21,6,0)
self-asserted; essentially a persistent identifier. Requires no identity
"^DD",3.081,3.081,101,21,7,0)
proofing, allows any type of token including a simple PIN. Examples: 
"^DD",3.081,3.081,101,21,8,0)
Old-style RPC Broker Visitor Access; Identification by DUZ without 
"^DD",3.081,3.081,101,21,9,0)
authentication (re-authentication using DUZ only).
"^DD",3.081,3.081,101,21,10,0)
 
"^DD",3.081,3.081,101,21,11,0)
LOA=2
"^DD",3.081,3.081,101,21,12,0)
   Confidence exists that the asserted identity is accurate; used 
"^DD",3.081,3.081,101,21,13,0)
frequently for self-service applications. Requires identity proofing, 
"^DD",3.081,3.081,101,21,14,0)
allows single-factor authentication. Passwords are the norm at this level.
"^DD",3.081,3.081,101,21,15,0)
Examples: VistA Access and Verify Code; Windows Username and Password;
"^DD",3.081,3.081,101,21,16,0)
Broker Security Enhancement (BSE) Visitor Access; Auto sign-on and CCOW 
"^DD",3.081,3.081,101,21,17,0)
token re-authentication.
"^DD",3.081,3.081,101,21,18,0)
 
"^DD",3.081,3.081,101,21,19,0)
LOA=3
"^DD",3.081,3.081,101,21,20,0)
   High confidence in the asserted identity's accuracy; used to access
"^DD",3.081,3.081,101,21,21,0)
restricted data. Requires stringent identity proofing, multi-factor
"^DD",3.081,3.081,101,21,22,0)
authentication, typically a password or biometric factor used in
"^DD",3.081,3.081,101,21,23,0)
combination with a 1) software token, 2) hardware token, or 3) one-time
"^DD",3.081,3.081,101,21,24,0)
password device token. Examples: OTP devices; X.509 user certificates.
"^DD",3.081,3.081,101,21,25,0)
 
"^DD",3.081,3.081,101,21,26,0)
LOA=4
"^DD",3.081,3.081,101,21,27,0)
   Very high confidence in the asserted identity's accuracy; used to 
"^DD",3.081,3.081,101,21,28,0)
access highly restricted data. Requires stringent and in-person 
"^DD",3.081,3.081,101,21,29,0)
registration, multi-factor authentication with a hardware crypto token 
"^DD",3.081,3.081,101,21,30,0)
(use of bearer tokens is not permitted). Examples: X.509 user certificates
"^DD",3.081,3.081,101,21,31,0)
on a hardware token that is FIPS 140-2 compliant; PIV card.
"^DD",3.081,3.081,101,"DT")
3150528
"^DD",8989.3,8989.3,200.1,0)
SECURITY TOKEN SERVICE^F^^200;1^K:$L(X)>60!($L(X)<3) X
"^DD",8989.3,8989.3,200.1,3)
Issuer of security token. Answer must be 3-60 characters in length.
"^DD",8989.3,8989.3,200.1,21,0)
^^11^11^3150916^
"^DD",8989.3,8989.3,200.1,21,1,0)
When using brokered authentication with a security token issued by a 
"^DD",8989.3,8989.3,200.1,21,2,0)
Security Token Service (STS), this field will contain the identification 
"^DD",8989.3,8989.3,200.1,21,3,0)
of the issuer of the token. The STS is trusted by both the client and the 
"^DD",8989.3,8989.3,200.1,21,4,0)
service to provide interoperable security tokens.
"^DD",8989.3,8989.3,200.1,21,5,0)
 
"^DD",8989.3,8989.3,200.1,21,6,0)
Security Assertion Markup Language (SAML) tokens are standards-based XML 
"^DD",8989.3,8989.3,200.1,21,7,0)
tokens that are used to exchange security information, including 
"^DD",8989.3,8989.3,200.1,21,8,0)
attribute statements, authentication decision statements, and 
"^DD",8989.3,8989.3,200.1,21,9,0)
authorization decision statements. They can be used as part of a Single 
"^DD",8989.3,8989.3,200.1,21,10,0)
Sign-On (SSO) solution allowing a client to talk to services running on 
"^DD",8989.3,8989.3,200.1,21,11,0)
disparate technologies.
"^DD",8989.3,8989.3,200.1,"DT")
3150916
"^DD",8989.3,8989.3,200.2,0)
ORGANIZATION^F^^200;2^K:$L(X)>50!($L(X)<3) X
"^DD",8989.3,8989.3,200.2,3)
Name of Organization (owner of this VistA instance). Answer must be 3-50 characters in length.
"^DD",8989.3,8989.3,200.2,21,0)
^^5^5^3150916^
"^DD",8989.3,8989.3,200.2,21,1,0)
Identity and Access Management ORGANIZATION field used to identify the 
"^DD",8989.3,8989.3,200.2,21,2,0)
Organization of this VistA instance. For internally authenticated users, 
"^DD",8989.3,8989.3,200.2,21,3,0)
this field will match the SUBJECT ORGANIZATION field (#205.2) of the user 
"^DD",8989.3,8989.3,200.2,21,4,0)
identified in the NEW PERSON file (#200). For the VA, this field should 
"^DD",8989.3,8989.3,200.2,21,5,0)
always contain the value: "Department Of Veterans Affairs"
"^DD",8989.3,8989.3,200.2,"DT")
3150916
"^DD",8989.3,8989.3,200.3,0)
ORGANIZATION ID^F^^200;3^K:$L(X)>50!($L(X)<1) X
"^DD",8989.3,8989.3,200.3,3)
ID of Organization (owner of this VistA instance). Answer must be 1-50 characters in length.
"^DD",8989.3,8989.3,200.3,21,0)
^^6^6^3150916^
"^DD",8989.3,8989.3,200.3,21,1,0)
Identity and Access Management ORGANIZATION ID field used to uniquely 
"^DD",8989.3,8989.3,200.3,21,2,0)
identify the Organization of this VistA instance. For internally 
"^DD",8989.3,8989.3,200.3,21,3,0)
authenticated users, this field will match the SUBJECT ORGANIZATION ID 
"^DD",8989.3,8989.3,200.3,21,4,0)
field (#205.3) of the user identified in the NEW PERSON file (#200). For 
"^DD",8989.3,8989.3,200.3,21,5,0)
the VA, this field should always contain the value: 
"^DD",8989.3,8989.3,200.3,21,6,0)
"urn:oid:2.16.840.1.113883.4.349"
"^DD",8989.3,8989.3,200.3,"DT")
3150916
"BLD",1548,6)
9^
$END KID XU*8.0*659
